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 – 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
Files:
2 deleted
146 edited

Legend:

Unmodified
Added
Removed

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/LIM_SRC_2/limistate_2.F90

    r4990 r7256  
    6969      IF( .NOT. ln_limini ) THEN   
    7070          
    71          tfu(:,:) = eos_fzp( tsn(:,:,1,jp_sal) ) * tmask(:,:,1)       ! freezing/melting point of sea water [Celcius] 
     71         CALL eos_fzp( tsn(:,:,1,jp_sal), tfu(:,:) )       ! freezing/melting point of sea water [Celcius] 
     72         tfu(:,:) = tfu(:,:) *  tmask(:,:,1) 
    7273 
    7374         DO jj = 1, jpj 

  • 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) ,                        & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r3680 r7256  
    11#if defined key_agrif 
    2    !!---------------------------------------------------------------------- 
    3    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    4    !! $Id$ 
    5    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6    !!---------------------------------------------------------------------- 
    7    SUBROUTINE Agrif2Model 
    8       !!--------------------------------------------- 
    9       !!   *** ROUTINE Agrif2Model *** 
    10       !!---------------------------------------------  
    11    END SUBROUTINE Agrif2model 
     2!!---------------------------------------------------------------------- 
     3!! NEMO/NST 3.6 , NEMO Consortium (2010) 
     4!! $Id$ 
     5!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     6!!---------------------------------------------------------------------- 
     7SUBROUTINE Agrif2Model 
     8   !!--------------------------------------------- 
     9   !!   *** ROUTINE Agrif2Model *** 
     10   !!---------------------------------------------  
     11END SUBROUTINE Agrif2model 
    1212 
    13    SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
    14       !!--------------------------------------------- 
    15       !!   *** ROUTINE Agrif_Set_numberofcells *** 
    16       !!---------------------------------------------  
    17       USE Agrif_Types 
    18       IMPLICIT NONE 
     13SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
     14   !!--------------------------------------------- 
     15   !!   *** ROUTINE Agrif_Set_numberofcells *** 
     16   !!---------------------------------------------  
     17   USE Agrif_Grids 
     18   IMPLICIT NONE 
    1919 
    20       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     20   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    2121 
    22       IF ( associated(Agrif_Curgrid) )THEN 
     22   IF ( ASSOCIATED(Agrif_Curgrid) )THEN 
    2323#include "SetNumberofcells.h" 
    24       ENDIF 
     24   ENDIF 
    2525 
    26    END SUBROUTINE Agrif_Set_numberofcells 
     26END SUBROUTINE Agrif_Set_numberofcells 
    2727 
    28    SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
    29       !!--------------------------------------------- 
    30       !!   *** ROUTINE Agrif_Get_numberofcells *** 
    31       !!---------------------------------------------  
    32       USE Agrif_Types 
    33       IMPLICIT NONE 
     28SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
     29   !!--------------------------------------------- 
     30   !!   *** ROUTINE Agrif_Get_numberofcells *** 
     31   !!---------------------------------------------  
     32   USE Agrif_Grids 
     33   IMPLICIT NONE 
    3434 
    35       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     35   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    3636 
     37   IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 
    3738#include "GetNumberofcells.h" 
     39   ENDIF 
    3840 
    39    END SUBROUTINE Agrif_Get_numberofcells 
     41END SUBROUTINE Agrif_Get_numberofcells 
    4042 
    41    SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
    42       !!--------------------------------------------- 
    43       !!   *** ROUTINE Agrif_Allocationscalls *** 
    44       !!---------------------------------------------  
    45       USE Agrif_Types  
     43SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
     44   !!--------------------------------------------- 
     45   !!   *** ROUTINE Agrif_Allocationscalls *** 
     46   !!---------------------------------------------  
     47   USE Agrif_Grids  
    4648#include "include_use_Alloc_agrif.h" 
    47       IMPLICIT NONE 
     49   IMPLICIT NONE 
    4850 
    49       Type(Agrif_Grid), Pointer :: Agrif_Gr 
     51   TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
    5052 
    5153#include "allocations_calls_agrif.h" 
    5254 
    53    END SUBROUTINE Agrif_Allocationcalls 
     55END SUBROUTINE Agrif_Allocationcalls 
    5456 
    55    SUBROUTINE Agrif_probdim_modtype_def() 
    56       !!--------------------------------------------- 
    57       !!   *** ROUTINE Agrif_probdim_modtype_def *** 
    58       !!---------------------------------------------  
    59       USE Agrif_Types 
    60       IMPLICIT NONE 
     57SUBROUTINE Agrif_probdim_modtype_def() 
     58   !!--------------------------------------------- 
     59   !!   *** ROUTINE Agrif_probdim_modtype_def *** 
     60   !!---------------------------------------------  
     61   USE Agrif_Types 
     62   IMPLICIT NONE 
    6163 
    6264#include "modtype_agrif.h" 
    … …  
    6466#include "keys_agrif.h" 
    6567 
    66       Return 
     68   RETURN 
    6769 
    68    END SUBROUTINE Agrif_probdim_modtype_def 
     70END SUBROUTINE Agrif_probdim_modtype_def 
    6971 
    70    SUBROUTINE Agrif_clustering_def() 
    71       !!--------------------------------------------- 
    72       !!   *** ROUTINE Agrif_clustering_def *** 
    73       !!---------------------------------------------  
    74       Use Agrif_Types 
    75       IMPLICIT NONE 
     72SUBROUTINE Agrif_clustering_def() 
     73   !!--------------------------------------------- 
     74   !!   *** ROUTINE Agrif_clustering_def *** 
     75   !!---------------------------------------------  
     76   IMPLICIT NONE 
    7677 
    77       Return 
     78   RETURN 
    7879 
    79    END SUBROUTINE Agrif_clustering_def 
     80END SUBROUTINE Agrif_clustering_def 
    8081 
    81    SUBROUTINE Agrif_comm_def(modelcomm) 
    82  
    83       !!--------------------------------------------- 
    84       !!   *** ROUTINE Agrif_clustering_def *** 
    85       !!---------------------------------------------  
    86       Use Agrif_Types 
    87       Use lib_mpp 
    88  
    89       IMPLICIT NONE 
    90  
    91       INTEGER :: modelcomm 
    92  
    93 #if defined key_mpp_mpi 
    94       modelcomm = mpi_comm_opa 
     82#else 
     83SUBROUTINE Agrif2Model 
     84   !!--------------------------------------------- 
     85   !!   *** ROUTINE Agrif2Model *** 
     86   !!---------------------------------------------  
     87   WRITE(*,*) 'Impossible to bet here' 
     88END SUBROUTINE Agrif2model 
    9589#endif 
    96       Return 
    97  
    98    END SUBROUTINE Agrif_comm_def 
    99 #else 
    100    SUBROUTINE Agrif2Model 
    101       !!--------------------------------------------- 
    102       !!   *** ROUTINE Agrif2Model *** 
    103       !!---------------------------------------------  
    104       WRITE(*,*) 'Impossible to bet here' 
    105    END SUBROUTINE Agrif2model 
    106 #endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r3680 r7256  
    99   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_agrif && defined key_lim2 
     11#if defined key_agrif && defined key_lim2  
    1212   !!---------------------------------------------------------------------- 
    1313   !!   'key_lim2'  :                                 LIM 2.0 sea-ice model 
    … …  
    4141   PUBLIC interp_adv_ice 
    4242 
     43   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 
     44   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr  
     45 
     46 
    4347   !!---------------------------------------------------------------------- 
    4448   !! NEMO/NST 3.4 , NEMO Consortium (2012) 
    … …  
    6569      u_ice_nst(:,:) = 0. 
    6670      v_ice_nst(:,:) = 0. 
    67       CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
    68       CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
     71      CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
     72      CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
    6973      Agrif_SpecialValue=0. 
    7074      Agrif_UseSpecialValue = .FALSE. 
    … …  
    138142      !!  we are in inside a new parent ice time step 
    139143      !!----------------------------------------------------------------------- 
    140       REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice 
    141144      INTEGER :: ji,jj 
    142145      REAL(wp) :: zrhox, zrhoy 
    … …  
    155158         Agrif_SpecialValue=-9999. 
    156159         Agrif_UseSpecialValue = .TRUE. 
    157          zuice = 0. 
    158          zvice = 0. 
    159          CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 
    160          CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 
     160         IF( .NOT. ALLOCATED(uice_agr) )THEN 
     161            ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 
     162         ENDIF 
     163         uice_agr = 0. 
     164         vice_agr = 0. 
     165         CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 
     166         CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 
    161167         Agrif_SpecialValue=0. 
    162168         Agrif_UseSpecialValue = .FALSE. 
    163169         !   
    164170         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()       
    165          zuice(:,:) =  zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
    166          zvice(:,:) =  zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
     171         uice_agr(:,:) =  uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
     172         vice_agr(:,:) =  vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
    167173         ! fill  boundaries 
    168174         DO jj = 1, jpj 
    169175            DO ji = 1, 2 
    170                u_ice_oe(ji,  jj,2) = zuice(ji       ,jj)  
    171                u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj) 
     176               u_ice_oe(ji,  jj,2) = uice_agr(ji       ,jj)  
     177               u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 
    172178            END DO 
    173179         END DO 
    174180         DO jj = 1, jpj 
    175             v_ice_oe(2,jj,2) = zvice(2     ,jj)  
    176             v_ice_oe(4,jj,2) = zvice(nlci-1,jj) 
     181            v_ice_oe(2,jj,2) = vice_agr(2     ,jj)  
     182            v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 
    177183         END DO 
    178184         DO ji = 1, jpi 
    179             u_ice_sn(ji,2,2) = zuice(ji,2     )  
    180             u_ice_sn(ji,4,2) = zuice(ji,nlcj-1) 
     185            u_ice_sn(ji,2,2) = uice_agr(ji,2     )  
     186            u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 
    181187         END DO 
    182188         DO jj = 1, 2 
    183189            DO ji = 1, jpi 
    184                v_ice_sn(ji,jj  ,2) = zvice(ji,jj       )  
    185                v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3) 
     190               v_ice_sn(ji,jj  ,2) = vice_agr(ji,jj       )  
     191               v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 
    186192            END DO 
    187193         END DO 
    … …  
    334340      !!  we are in inside a new parent ice time step 
    335341     !!----------------------------------------------------------------------- 
    336       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    337342      INTEGER :: ji,jj,jn 
    338343      !!----------------------------------------------------------------------- 
    … …  
    345350         adv_ice_sn(:,:,:,1) =  adv_ice_sn(:,:,:,2) 
    346351         ! interpolation of boundaries 
    347          ztab(:,:,:) = 0. 
     352         IF(.NOT.ALLOCATED(tabice_agr))THEN 
     353            ALLOCATE(tabice_agr(jpi,jpj,7))    
     354         ENDIF 
     355         tabice_agr(:,:,:) = 0. 
    348356         Agrif_SpecialValue=-9999. 
    349357         Agrif_UseSpecialValue = .TRUE. 
    350          CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
     358         CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
    351359         Agrif_SpecialValue=0. 
    352360         Agrif_UseSpecialValue = .FALSE. 
    … …  
    356364            DO jj = 1, jpj 
    357365               DO ji=1,2 
    358                   adv_ice_oe(ji  ,jj,jn,2) = ztab(ji       ,jj,jn)  
    359                   adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn) 
     366                  adv_ice_oe(ji  ,jj,jn,2) = tabice_agr(ji       ,jj,jn)  
     367                  adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 
    360368               END DO 
    361369            END DO 
    … …  
    365373            Do jj =1,2 
    366374               DO ji = 1, jpi 
    367                   adv_ice_sn(ji,jj  ,jn,2) = ztab(ji,jj       ,jn)  
    368                   adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn) 
     375                  adv_ice_sn(ji,jj  ,jn,2) = tabice_agr(ji,jj       ,jn)  
     376                  adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 
    369377               END DO 
    370378            END DO 
    … …  
    384392      INTEGER :: ji,jj,jn 
    385393      REAL(wp) :: zalpha 
    386       REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    387394      !!-----------------------------------------------------------------------       
    388395      ! 
    … …  
    391398      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 
    392399      ! 
    393       ztab(:,:,:) = 0.e0 
     400      tabice_agr(:,:,:) = 0.e0 
    394401      DO jn =1,7 
    395402         DO jj =1,2 
    396403            DO ji = 1, jpi 
    397                ztab(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
    398                ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
     404               tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
     405               tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
    399406            END DO 
    400407         END DO 
    … …  
    404411         DO jj = 1, jpj 
    405412            DO ji=1,2 
    406                ztab(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
    407                ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
     413               tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
     414               tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
    408415            END DO 
    409416         END DO 
    410417      END DO 
    411418      ! 
    412       CALL parcoursT( ztab(:,:, 1), frld  ) 
    413       CALL parcoursT( ztab(:,:, 2), hicif ) 
    414       CALL parcoursT( ztab(:,:, 3), hsnif ) 
    415       CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) ) 
    416       CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) ) 
    417       CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) ) 
    418       CALL parcoursT( ztab(:,:, 7), qstoif ) 
     419      CALL parcoursT( tabice_agr(:,:, 1), frld  ) 
     420      CALL parcoursT( tabice_agr(:,:, 2), hicif ) 
     421      CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 
     422      CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 
     423      CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 
     424      CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 
     425      CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 
    419426      ! 
    420427   END SUBROUTINE agrif_trp_lim2 
    … …  
    499506 
    500507 
    501    SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 ) 
     508   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 
    502509      !!----------------------------------------------------------------------- 
    503510      !!                     *** ROUTINE interp_u_ice *** 
    … …  
    505512      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    506513      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     514      LOGICAL, INTENT(in) :: before 
    507515      !! 
    508516      INTEGER :: ji,jj 
    … …  
    510518      ! 
    511519#if defined key_lim2_vp 
    512       DO jj=MAX(j1,2),j2 
    513          DO ji=MAX(i1,2),i2 
    514             IF( tmu(ji,jj) == 0. ) THEN 
    515                tabres(ji,jj) = -9999. 
    516             ELSE 
    517                tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
    518             ENDIF 
    519          END DO 
    520       END DO 
     520      IF( before ) THEN 
     521         DO jj=MAX(j1,2),j2 
     522            DO ji=MAX(i1,2),i2 
     523               IF( tmu(ji,jj) == 0. ) THEN 
     524                  tabres(ji,jj) = -9999. 
     525               ELSE 
     526                  tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
     527               ENDIF 
     528            END DO 
     529         END DO 
     530      ELSE 
     531         DO jj=MAX(j1,2),j2 
     532            DO ji=MAX(i1,2),i2 
     533               uice_agr(ji,jj) = tabres(ji,jj) 
     534            END DO 
     535         END DO 
     536      ENDIF 
    521537#else 
    522       DO jj= j1, j2 
    523          DO ji= i1, i2 
    524             IF( umask(ji,jj,1) == 0. ) THEN 
    525                tabres(ji,jj) = -9999. 
    526             ELSE 
    527                tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
    528             ENDIF 
    529          END DO 
    530       END DO 
     538      IF( before ) THEN 
     539         DO jj= j1, j2 
     540            DO ji= i1, i2 
     541               IF( umask(ji,jj,1) == 0. ) THEN 
     542                  tabres(ji,jj) = -9999. 
     543               ELSE 
     544                  tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
     545               ENDIF 
     546            END DO 
     547         END DO 
     548      ELSE 
     549         DO jj= j1, j2 
     550            DO ji= i1, i2 
     551               uice_agr(ji,jj) = tabres(ji,jj) 
     552            END DO 
     553         END DO 
     554      ENDIF 
    531555#endif 
    532556   END SUBROUTINE interp_u_ice 
    533557 
    534558 
    535    SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 ) 
     559   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 
    536560      !!----------------------------------------------------------------------- 
    537561      !!                    *** ROUTINE interp_v_ice *** 
    … …  
    539563      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    540564      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     565      LOGICAL, INTENT(in) :: before 
    541566      !! 
    542567      INTEGER :: ji, jj 
    … …  
    544569      ! 
    545570#if defined key_lim2_vp 
    546       DO jj=MAX(j1,2),j2 
    547          DO ji=MAX(i1,2),i2 
    548             IF( tmu(ji,jj) == 0. ) THEN 
    549                tabres(ji,jj) = -9999. 
    550             ELSE 
    551                tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    552             ENDIF 
    553          END DO 
    554       END DO 
     571      IF( before ) THEN 
     572         DO jj=MAX(j1,2),j2 
     573            DO ji=MAX(i1,2),i2 
     574               IF( tmu(ji,jj) == 0. ) THEN 
     575                  tabres(ji,jj) = -9999. 
     576               ELSE 
     577                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
     578               ENDIF 
     579            END DO 
     580         END DO 
     581      ELSE 
     582         DO jj=MAX(j1,2),j2 
     583            DO ji=MAX(i1,2),i2 
     584               vice_agr(ji,jj) = tabres(ji,jj) 
     585            END DO 
     586         END DO 
     587      ENDIF    
    555588#else 
    556       DO jj= j1 ,j2 
    557          DO ji = i1, i2 
    558             IF( vmask(ji,jj,1) == 0. ) THEN 
    559                tabres(ji,jj) = -9999. 
    560             ELSE 
    561                tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
    562             ENDIF 
    563          END DO 
    564       END DO 
     589      IF( before ) THEN 
     590         DO jj= j1 ,j2 
     591            DO ji = i1, i2 
     592               IF( vmask(ji,jj,1) == 0. ) THEN 
     593                  tabres(ji,jj) = -9999. 
     594               ELSE 
     595                  tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
     596               ENDIF 
     597            END DO 
     598         END DO 
     599      ELSE 
     600         DO jj= j1 ,j2 
     601            DO ji = i1, i2 
     602               vice_agr(ji,jj) = tabres(ji,jj) 
     603            END DO 
     604         END DO 
     605      ENDIF 
    565606#endif 
    566607   END SUBROUTINE interp_v_ice 
    567608 
    568609 
    569    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 ) 
     610   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) 
    570611      !!----------------------------------------------------------------------- 
    571612      !!                    *** ROUTINE interp_adv_ice ***                            
    … …  
    575616      !!              put -9999 where no ice for correct extrapolation              
    576617      !!----------------------------------------------------------------------- 
    577       INTEGER, INTENT(in) :: i1, i2, j1, j2 
    578       REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
     618      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     619      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     620      LOGICAL, INTENT(in) :: before 
    579621      !! 
    580622      INTEGER :: ji, jj, jk 
    581623      !!----------------------------------------------------------------------- 
    582624      ! 
    583       DO jj=j1,j2 
    584          DO ji=i1,i2 
    585             IF( tms(ji,jj) == 0. ) THEN 
    586                tabres(ji,jj,:) = -9999.  
    587             ELSE 
    588                tabres(ji,jj, 1) = frld  (ji,jj) 
    589                tabres(ji,jj, 2) = hicif (ji,jj) 
    590                tabres(ji,jj, 3) = hsnif (ji,jj) 
    591                tabres(ji,jj, 4) = tbif  (ji,jj,1) 
    592                tabres(ji,jj, 5) = tbif  (ji,jj,2) 
    593                tabres(ji,jj, 6) = tbif  (ji,jj,3) 
    594                tabres(ji,jj, 7) = qstoif(ji,jj) 
    595             ENDIF 
    596          END DO 
    597       END DO 
     625      IF( before ) THEN 
     626         DO jj=j1,j2 
     627       DO ji=i1,i2 
     628          IF( tms(ji,jj) == 0. ) THEN 
     629             tabres(ji,jj,:) = -9999  
     630          ELSE 
     631             tabres(ji,jj, 1) = frld  (ji,jj) 
     632             tabres(ji,jj, 2) = hicif (ji,jj) 
     633             tabres(ji,jj, 3) = hsnif (ji,jj) 
     634             tabres(ji,jj, 4) = tbif  (ji,jj,1) 
     635             tabres(ji,jj, 5) = tbif  (ji,jj,2) 
     636             tabres(ji,jj, 6) = tbif  (ji,jj,3) 
     637             tabres(ji,jj, 7) = qstoif(ji,jj) 
     638          ENDIF 
     639       END DO 
     640         END DO 
     641      ELSE 
     642    DO jj=j1,j2 
     643       DO ji=i1,i2 
     644               DO jk=k1, k2 
     645             tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) 
     646               END DO 
     647       END DO 
     648    END DO 
     649      ENDIF 
    598650      ! 
    599651   END SUBROUTINE interp_adv_ice 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r3680 r7256  
    5252      INTEGER, INTENT(in) :: kt 
    5353      !! 
    54       REAL(wp), DIMENSION(jpi,jpj)  :: zvel 
    55       REAL(wp), DIMENSION(jpi,jpj,7):: zadv 
    5654      !!---------------------------------------------------------------------- 
    5755      ! 
    … …  
    6058      Agrif_UseSpecialValueInUpdate = .TRUE. 
    6159      Agrif_SpecialValueFineGrid = 0. 
    62  
    6360# if defined TWO_WAY 
    6461      IF( MOD(nbcline,nbclineupdate) == 0) THEN 
    65          CALL Agrif_Update_Variable( zadv , adv_ice_id , procname = update_adv_ice  ) 
    66          CALL Agrif_Update_Variable( zvel , u_ice_id   , procname = update_u_ice    ) 
    67          CALL Agrif_Update_Variable( zvel , v_ice_id   , procname = update_v_ice    ) 
    68       ELSE 
    69          CALL Agrif_Update_Variable( zadv , adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
    70          CALL Agrif_Update_Variable( zvel , u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
    71          CALL Agrif_Update_Variable( zvel , v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
     62         CALL Agrif_Update_Variable( adv_ice_id , procname = update_adv_ice  ) 
     63         CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    ) 
     64         CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    ) 
     65      ELSE 
     66         CALL Agrif_Update_Variable( adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
     67         CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
     68         CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
    7269      ENDIF 
    7370# endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

    r4491 r7256  
    1212   USE par_oce      ! ocean parameters 
    1313   USE dom_oce      ! domain parameters 
    14     
     14 
    1515   IMPLICIT NONE 
    1616   PRIVATE  
    … …  
    1919 
    2020   !                                              !!* Namelist namagrif: AGRIF parameters 
    21    LOGICAL , PUBLIC ::   ln_spc_dyn      !: 
    22    INTEGER , PUBLIC ::   nn_cln_update   !: update frequency  
    23    REAL(wp), PUBLIC ::   rn_sponge_tra   !: sponge coeff. for tracers 
    24    REAL(wp), PUBLIC ::   rn_sponge_dyn   !: sponge coeff. for dynamics 
     21   LOGICAL , PUBLIC ::   ln_spc_dyn    = .FALSE.   !: 
     22   INTEGER , PUBLIC ::   nn_cln_update = 3         !: update frequency  
     23   INTEGER , PUBLIC, PARAMETER ::   nn_sponge_len = 2  !: Sponge width (in number of parent grid points) 
     24   REAL(wp), PUBLIC ::   rn_sponge_tra = 2800.     !: sponge coeff. for tracers 
     25   REAL(wp), PUBLIC ::   rn_sponge_dyn = 2800.     !: sponge coeff. for dynamics 
     26   LOGICAL , PUBLIC ::   ln_chk_bathy  = .FALSE.   !: check of parent bathymetry  
    2527 
    2628   !                                              !!! OLD namelist names 
    … …  
    3032   REAL(wp), PUBLIC ::   visc_dyn                  !: sponge coeff. for dynamics 
    3133 
    32    LOGICAL , PUBLIC :: spongedoneT = .FALSE.   !: tracer   sponge layer indicator 
    33    LOGICAL , PUBLIC :: spongedoneU = .FALSE.   !: dynamics sponge layer indicator 
    34    LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE. !: if true: first step 
     34   LOGICAL , PUBLIC :: spongedoneT = .FALSE.       !: tracer   sponge layer indicator 
     35   LOGICAL , PUBLIC :: spongedoneU = .FALSE.       !: dynamics sponge layer indicator 
     36   LOGICAL , PUBLIC :: lk_agrif_fstep = .TRUE.     !: if true: first step 
     37   LOGICAL , PUBLIC :: lk_agrif_doupd = .TRUE.     !: if true: send update from current grid 
     38   LOGICAL , PUBLIC :: lk_agrif_debug = .FALSE.    !: if true: print debugging info 
    3539 
    36    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur , spe2vr , spbtr2   !: ??? 
    37    REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) ::   spe1ur2, spe2vr2, spbtr3   !: ??? 
    38     
    39    INTEGER :: tsn_id,tsb_id,tsa_id 
    40    INTEGER :: un_id, vn_id, ua_id, va_id 
    41    INTEGER :: e1u_id, e2v_id, sshn_id, gcb_id 
    42    INTEGER :: trn_id, trb_id, tra_id 
    43    INTEGER :: unb_id, vnb_id, ub2b_id, vb2b_id 
     40   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_tsn 
     41# if defined key_top 
     42   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_trn 
     43# endif 
     44   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_u 
     45   LOGICAL , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tabspongedone_v 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsaht_spu, fsaht_spv !: sponge diffusivities 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE,  DIMENSION(:,:) :: fsahm_spt, fsahm_spf !: sponge viscosities 
     48 
     49   ! Barotropic arrays used to store open boundary data during 
     50   ! time-splitting loop: 
     51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
     52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
     53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
     54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
     55 
     56   INTEGER :: tsn_id                                                  ! AGRIF profile for tracers interpolation and update 
     57   INTEGER :: un_interp_id, vn_interp_id                              ! AGRIF profiles for interpolations 
     58   INTEGER :: un_update_id, vn_update_id                              ! AGRIF profiles for udpates 
     59   INTEGER :: tsn_sponge_id, un_sponge_id, vn_sponge_id               ! AGRIF profiles for sponge layers 
     60# if defined key_top 
     61   INTEGER :: trn_id, trn_sponge_id 
     62# endif   
     63   INTEGER :: unb_id, vnb_id, ub2b_interp_id, vb2b_interp_id 
     64   INTEGER :: ub2b_update_id, vb2b_update_id 
     65   INTEGER :: e3t_id, e1u_id, e2v_id, sshn_id 
     66   INTEGER :: scales_t_id 
     67# if defined key_zdftke 
     68   INTEGER :: avt_id, avm_id, en_id 
     69# endif   
     70   INTEGER :: umsk_id, vmsk_id 
     71   INTEGER :: kindic_agr 
    4472 
    4573   !!---------------------------------------------------------------------- 
    … …  
    5482      !!                ***  FUNCTION agrif_oce_alloc  *** 
    5583      !!---------------------------------------------------------------------- 
    56       ALLOCATE( spe1ur (jpi,jpj) , spe2vr (jpi,jpj) , spbtr2(jpi,jpj) ,      & 
    57          &      spe1ur2(jpi,jpj) , spe2vr2(jpi,jpj) , spbtr3(jpi,jpj) , STAT = agrif_oce_alloc )  
     84      INTEGER, DIMENSION(2) :: ierr 
     85      !!---------------------------------------------------------------------- 
     86      ierr(:) = 0 
     87      ! 
     88      ALLOCATE( fsaht_spu(jpi,jpj), fsaht_spv(jpi,jpj),   & 
     89         &      fsahm_spt(jpi,jpj), fsahm_spf(jpi,jpj),   & 
     90         &      tabspongedone_tsn(jpi,jpj),           & 
     91# if defined key_top          
     92         &      tabspongedone_trn(jpi,jpj),           & 
     93# endif          
     94         &      tabspongedone_u  (jpi,jpj),           & 
     95         &      tabspongedone_v  (jpi,jpj), STAT = ierr(1) ) 
     96 
     97      ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj),   & 
     98         &      ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj),   &  
     99         &      ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi),   &  
     100         &      ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi), STAT = ierr(2) ) 
     101 
     102      agrif_oce_alloc = MAXVAL(ierr) 
     103      ! 
    58104   END FUNCTION agrif_oce_alloc 
    59105 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r4486 r7256  
    77   !!             -   !  2005-11  (XXX)  
    88   !!            3.2  !  2009-04  (R. Benshila)  
     9   !!            3.6  !  2014-09  (R. Benshila)  
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_agrif && ! defined key_offline 
    … …  
    2930   USE wrk_nemo 
    3031   USE dynspg_oce 
    31  
     32   USE zdf_oce 
     33  
    3234   IMPLICIT NONE 
    3335   PRIVATE 
    3436 
    35    ! Barotropic arrays used to store open boundary data during 
    36    ! time-splitting loop: 
    37    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
    38    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
    39    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
    40    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
    41      
     37   INTEGER :: bdy_tinterp = 0 
     38 
    4239   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    43    PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
     40   PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
     41   PUBLIC   interptsn,  interpsshn 
     42   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
     43   PUBLIC   interpe3t, interpumsk, interpvmsk 
     44# if defined key_zdftke 
     45   PUBLIC   Agrif_tke, interpavm 
     46# endif 
    4447 
    4548#  include "domzgr_substitute.h90"   
    4649#  include "vectopt_loop_substitute.h90" 
    4750   !!---------------------------------------------------------------------- 
    48    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     51   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4952   !! $Id$ 
    5053   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5154   !!---------------------------------------------------------------------- 
    5255 
    53    CONTAINS 
    54     
     56CONTAINS 
     57 
    5558   SUBROUTINE Agrif_tra 
    5659      !!---------------------------------------------------------------------- 
    57       !!                  ***  ROUTINE Agrif_Tra  *** 
    58       !!---------------------------------------------------------------------- 
    59       !! 
    60       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    61       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    62       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    63       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 
     60      !!                  ***  ROUTINE Agrif_tra  *** 
    6461      !!---------------------------------------------------------------------- 
    6562      ! 
    6663      IF( Agrif_Root() )   RETURN 
    67  
    68       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
    6964 
    7065      Agrif_SpecialValue    = 0.e0 
    7166      Agrif_UseSpecialValue = .TRUE. 
    72       ztsa(:,:,:,:) = 0.e0 
    73  
    74       CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
     67 
     68      CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 
    7569      Agrif_UseSpecialValue = .FALSE. 
    76  
    77       zrhox = Agrif_Rhox() 
    78  
    79       alpha1 = ( zrhox - 1. ) * 0.5 
    80       alpha2 = 1. - alpha1 
    81  
    82       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    83       alpha4 = 1. - alpha3 
    84  
    85       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    86       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    87       alpha5 = 1. - alpha6 - alpha7 
    88  
    89       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    90  
    91          DO jn = 1, jpts 
    92             tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 
    93             DO jk = 1, jpkm1 
    94                DO jj = 1, jpj 
    95                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    96                      tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    97                   ELSE 
    98                      tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    99                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    100                         tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  & 
    101                            &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
    102                      ENDIF 
    103                   ENDIF 
    104                END DO 
    105             END DO 
    106          ENDDO 
    107       ENDIF 
    108  
    109       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    110  
    111          DO jn = 1, jpts 
    112             tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 
    113             DO jk = 1, jpkm1 
    114                DO ji = 1, jpi 
    115                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    116                      tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    117                   ELSE 
    118                      tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    119                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    120                         tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  & 
    121                            &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    122                      ENDIF 
    123                   ENDIF 
    124                END DO 
    125             END DO 
    126          ENDDO  
    127       ENDIF 
    128  
    129       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    130          DO jn = 1, jpts 
    131             tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
    132             DO jk = 1, jpkm1 
    133                DO jj = 1, jpj 
    134                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    135                      tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    136                   ELSE 
    137                      tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    138                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    139                         tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
    140                      ENDIF 
    141                   ENDIF 
    142                END DO 
    143             END DO 
    144          END DO 
    145       ENDIF 
    146  
    147       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    148          DO jn = 1, jpts 
    149             tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 
    150             DO jk=1,jpk       
    151                DO ji=1,jpi 
    152                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    153                      tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
    154                   ELSE 
    155                      tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
    156                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    157                         tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
    158                      ENDIF 
    159                   ENDIF 
    160                END DO 
    161             END DO 
    162          ENDDO 
    163       ENDIF 
    164       ! 
    165       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )  
    16670      ! 
    16771   END SUBROUTINE Agrif_tra 
    … …  
    17579      INTEGER, INTENT(in) ::   kt 
    17680      !! 
    177       INTEGER :: ji,jj,jk 
     81      INTEGER :: ji,jj,jk, j1,j2, i1,i2 
    17882      REAL(wp) :: timeref 
    17983      REAL(wp) :: z2dt, znugdt 
    18084      REAL(wp) :: zrhox, zrhoy 
    181       REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
    182       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
     85      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
    18386      !!----------------------------------------------------------------------   
    18487 
    18588      IF( Agrif_Root() )   RETURN 
    18689 
    187       CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    188       CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 
     90      CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 
     91 
     92      Agrif_SpecialValue=0. 
     93      Agrif_UseSpecialValue = ln_spc_dyn 
     94 
     95      CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 
     96      CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
     97 
     98#if defined key_dynspg_flt 
     99      CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 
     100      CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 
     101#endif 
     102 
     103      Agrif_UseSpecialValue = .FALSE. 
    189104 
    190105      zrhox = Agrif_Rhox() 
    … …  
    192107 
    193108      timeref = 1. 
    194  
    195109      ! time step: leap-frog 
    196110      z2dt = 2. * rdt 
    … …  
    200114      znugdt =  grav * z2dt     
    201115 
    202       Agrif_SpecialValue=0. 
    203       Agrif_UseSpecialValue = ln_spc_dyn 
    204  
    205       zua = 0. 
    206       zva = 0. 
    207       CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 
    208       CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 
    209       zua2d = 0. 
    210       zva2d = 0. 
    211  
     116      ! prevent smoothing in ghost cells 
     117      i1=1 
     118      i2=jpi 
     119      j1=1 
     120      j2=jpj 
     121      IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 
     122      IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 
     123      IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 
     124      IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 
     125 
     126 
     127      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    212128#if defined key_dynspg_flt 
    213       Agrif_SpecialValue=0. 
    214       Agrif_UseSpecialValue = ln_spc_dyn 
    215       CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
    216       CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
    217 #endif 
    218       Agrif_UseSpecialValue = .FALSE. 
    219  
    220  
    221       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    222  
    223 #if defined key_dynspg_flt 
    224          DO jj=1,jpj 
    225             laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 
    226          END DO 
    227 #endif 
     129         DO jk=1,jpkm1 
     130            DO jj=j1,j2 
     131               ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
     132            END DO 
     133         END DO 
     134 
     135         spgu(2,:)=0. 
    228136 
    229137         DO jk=1,jpkm1 
    230138            DO jj=1,jpj 
    231                ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 
    232                ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 
    233             END DO 
    234          END DO 
    235  
    236 #if defined key_dynspg_flt 
    237          DO jk=1,jpkm1 
    238             DO jj=1,jpj 
    239                ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
    240             END DO 
    241          END DO 
    242  
    243          spgu(2,:)=0. 
    244  
    245          DO jk=1,jpkm1 
    246             DO jj=1,jpj 
    247                spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     139               spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    248140            END DO 
    249141         END DO 
    … …  
    251143         DO jj=1,jpj 
    252144            IF (umask(2,jj,1).NE.0.) THEN 
    253                spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 
     145               spgu(2,jj)=spgu(2,jj)/hu(2,jj) 
    254146            ENDIF 
    255147         END DO 
    … …  
    259151 
    260152         DO jk=1,jpkm1 
    261             DO jj=1,jpj 
     153            DO jj=j1,j2 
    262154               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    263155               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    … …  
    269161         DO jk=1,jpkm1 
    270162            DO jj=1,jpj 
    271                spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
     163               spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
    272164            END DO 
    273165         END DO 
    … …  
    275167         DO jj=1,jpj 
    276168            IF (umask(2,jj,1).NE.0.) THEN 
    277                spgu1(2,jj)=spgu1(2,jj)*hur_a(2,jj) 
    278             ENDIF 
    279          END DO 
    280  
    281          DO jk=1,jpkm1 
    282             DO jj=1,jpj 
     169               spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 
     170            ENDIF 
     171         END DO 
     172 
     173         DO jk=1,jpkm1 
     174            DO jj=j1,j2 
    283175               ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 
    284             END DO 
    285          END DO 
    286  
    287          DO jk=1,jpkm1 
    288             DO jj=1,jpj 
    289                va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 
    290                va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk) 
    291176            END DO 
    292177         END DO 
    … …  
    300185            END DO 
    301186         END DO 
    302  
    303187         DO jj=1,jpj 
    304188            spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    305189         END DO 
    306  
    307190         DO jk=1,jpkm1 
    308191            DO jj=1,jpj 
    … …  
    316199      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    317200#if defined key_dynspg_flt 
    318          DO jj=1,jpj 
    319             laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 
    320          END DO 
    321 #endif 
    322  
     201         DO jk=1,jpkm1 
     202            DO jj=j1,j2 
     203               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
     204            END DO 
     205         END DO 
     206         spgu(nlci-2,:)=0. 
    323207         DO jk=1,jpkm1 
    324208            DO jj=1,jpj 
    325                ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 
    326                ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 
    327             END DO 
    328          END DO 
    329  
    330 #if defined key_dynspg_flt 
    331          DO jk=1,jpkm1 
    332             DO jj=1,jpj 
    333                ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
    334             END DO 
    335          END DO 
    336  
    337  
    338          spgu(nlci-2,:)=0. 
    339  
    340          do jk=1,jpkm1 
    341             do jj=1,jpj 
    342                spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    343             enddo 
    344          enddo 
    345  
     209               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
     210            ENDDO 
     211         ENDDO 
    346212         DO jj=1,jpj 
    347213            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    348                spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 
     214               spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 
    349215            ENDIF 
    350216         END DO 
    … …  
    352218         spgu(nlci-2,:) = ua_b(nlci-2,:) 
    353219#endif 
    354  
     220         DO jk=1,jpkm1 
     221            DO jj=j1,j2 
     222               ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
     223 
     224               ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
     225 
     226            END DO 
     227         END DO 
     228         spgu1(nlci-2,:)=0. 
    355229         DO jk=1,jpkm1 
    356230            DO jj=1,jpj 
    357                ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
    358  
    359                ua(nlci-2,jj,jk) = ua(nlci-2,jj,jk) * umask(nlci-2,jj,jk) 
    360  
    361             END DO 
    362          END DO 
    363  
    364          spgu1(nlci-2,:)=0. 
    365  
    366          DO jk=1,jpkm1 
    367             DO jj=1,jpj 
    368                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
    369             END DO 
    370          END DO 
    371  
     231               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
     232            END DO 
     233         END DO 
    372234         DO jj=1,jpj 
    373235            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    374                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 
    375             ENDIF 
    376          END DO 
    377  
    378          DO jk=1,jpkm1 
    379             DO jj=1,jpj 
     236               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 
     237            ENDIF 
     238         END DO 
     239         DO jk=1,jpkm1 
     240            DO jj=j1,j2 
    380241               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 
    381             END DO 
    382          END DO 
    383  
    384          DO jk=1,jpkm1 
    385             DO jj=1,jpj-1 
    386                va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 
    387                va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk) 
    388242            END DO 
    389243         END DO 
    … …  
    414268 
    415269#if defined key_dynspg_flt 
    416          DO ji=1,jpi 
    417             laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 
    418          END DO 
    419 #endif 
    420  
    421          DO jk=1,jpkm1 
    422             DO ji=1,jpi 
    423                va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 
    424                va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk) 
    425             END DO 
    426          END DO 
    427  
    428 #if defined key_dynspg_flt 
    429270         DO jk=1,jpkm1 
    430271            DO ji=1,jpi 
    … …  
    437278         DO jk=1,jpkm1 
    438279            DO ji=1,jpi 
    439                spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 
     280               spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 
    440281            END DO 
    441282         END DO 
    … …  
    443284         DO ji=1,jpi 
    444285            IF (vmask(ji,2,1).NE.0.) THEN 
    445                spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 
     286               spgv(ji,2)=spgv(ji,2)/hv(ji,2) 
    446287            ENDIF 
    447288         END DO 
    … …  
    451292 
    452293         DO jk=1,jpkm1 
    453             DO ji=1,jpi 
     294            DO ji=i1,i2 
    454295               va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    455296               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    … …  
    461302         DO jk=1,jpkm1 
    462303            DO ji=1,jpi 
    463                spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
     304               spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    464305            END DO 
    465306         END DO 
    … …  
    467308         DO ji=1,jpi 
    468309            IF (vmask(ji,2,1).NE.0.) THEN 
    469                spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 
     310               spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 
    470311            ENDIF 
    471312         END DO 
    … …  
    474315            DO ji=1,jpi 
    475316               va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 
    476             END DO 
    477          END DO 
    478  
    479          DO jk=1,jpkm1 
    480             DO ji=1,jpi 
    481                ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)  
    482                ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk) 
    483317            END DO 
    484318         END DO 
    … …  
    508342 
    509343#if defined key_dynspg_flt 
    510          DO ji=1,jpi 
    511             laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 
    512          END DO 
    513 #endif 
    514  
    515          DO jk=1,jpkm1 
    516             DO ji=1,jpi 
    517                va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 
    518                va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk) 
    519             END DO 
    520          END DO 
    521  
    522 #if defined key_dynspg_flt 
    523344         DO jk=1,jpkm1 
    524345            DO ji=1,jpi 
    … …  
    527348         END DO 
    528349 
     350 
    529351         spgv(:,nlcj-2)=0. 
    530352 
    531353         DO jk=1,jpkm1 
    532354            DO ji=1,jpi 
    533                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     355               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    534356            END DO 
    535357         END DO 
    … …  
    537359         DO ji=1,jpi 
    538360            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    539                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    540             ENDIF 
    541          END DO 
     361               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 
     362            ENDIF 
     363         END DO 
     364 
    542365#else 
    543366         spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    … …  
    545368 
    546369         DO jk=1,jpkm1 
    547             DO ji=1,jpi 
     370            DO ji=i1,i2 
    548371               va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    549372               va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    … …  
    555378         DO jk=1,jpkm1 
    556379            DO ji=1,jpi 
    557                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     380               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    558381            END DO 
    559382         END DO 
    … …  
    561384         DO ji=1,jpi 
    562385            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    563                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
     386               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 
    564387            ENDIF 
    565388         END DO 
    … …  
    568391            DO ji=1,jpi 
    569392               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
    570             END DO 
    571          END DO 
    572  
    573          DO jk=1,jpkm1 
    574             DO ji=1,jpi 
    575                ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
    576                ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk) 
    577393            END DO 
    578394         END DO 
    … …  
    600416      ENDIF 
    601417      ! 
    602       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
    603       CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 
     418      CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 
    604419      ! 
    605420   END SUBROUTINE Agrif_dyn 
    … …  
    620435         DO jj=1,jpj 
    621436            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    622 ! Specified fluxes: 
     437            ! Specified fluxes: 
    623438            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    624 ! Characteristics method: 
    625 !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    626 !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     439            ! Characteristics method: 
     440            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     441            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    627442         END DO 
    628443      ENDIF 
    … …  
    631446         DO jj=1,jpj 
    632447            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    633 ! Specified fluxes: 
     448            ! Specified fluxes: 
    634449            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    635 ! Characteristics method: 
    636 !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    637 !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     450            ! Characteristics method: 
     451            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     452            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    638453         END DO 
    639454      ENDIF 
    … …  
    642457         DO ji=1,jpi 
    643458            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    644 ! Specified fluxes: 
     459            ! Specified fluxes: 
    645460            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    646 ! Characteristics method: 
    647 !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    648 !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     461            ! Characteristics method: 
     462            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     463            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    649464         END DO 
    650465      ENDIF 
    … …  
    653468         DO ji=1,jpi 
    654469            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    655 ! Specified fluxes: 
     470            ! Specified fluxes: 
    656471            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    657 ! Characteristics method: 
    658 !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    659 !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     472            ! Characteristics method: 
     473            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     474            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    660475         END DO 
    661476      ENDIF 
    … …  
    672487      INTEGER :: ji, jj 
    673488      LOGICAL :: ll_int_cons 
    674       REAL(wp) :: zrhox, zrhoy, zrhot, zt 
    675       REAL(wp) :: zaa, zab, zat 
    676       REAL(wp) :: zt0, zt1 
    677       REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 
    678       REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 
     489      REAL(wp) :: zrhot, zt 
    679490      !!----------------------------------------------------------------------   
    680491 
    … …  
    682493 
    683494      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 
    684                              ! the forward case only 
    685  
    686       zrhox = Agrif_Rhox() 
    687       zrhoy = Agrif_Rhoy() 
     495      ! the forward case only 
     496 
    688497      zrhot = Agrif_rhot() 
    689  
    690       IF ( kt==nit000 ) THEN ! Allocate boundary data arrays 
    691          ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 
    692          ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 
    693          ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 
    694          ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 
    695       ENDIF 
    696  
    697       CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 
    698498 
    699499      ! "Central" time index for interpolation: 
    … …  
    707507      Agrif_SpecialValue    = 0.e0 
    708508      Agrif_UseSpecialValue = .TRUE. 
    709       CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 
     509      CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 
    710510      Agrif_UseSpecialValue = .FALSE. 
    711511 
    … …  
    715515 
    716516      IF (ll_int_cons) THEN ! Conservative interpolation 
    717          CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    718          zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 
    719          zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 
    720          zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 
    721          CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
    722          CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 
    723          CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 
    724          CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 
    725          CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 
    726          CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 
    727           
     517         ! orders matters here !!!!!! 
     518         CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 
     519         CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 
     520         bdy_tinterp = 1 
     521         CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 
     522         CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 
     523         bdy_tinterp = 2 
     524         CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
     525         CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb)          
     526      ELSE ! Linear interpolation 
     527         bdy_tinterp = 0 
     528         ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0  
     529         ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0  
     530         ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0  
     531         ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0  
     532         CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 
     533         CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 
     534      ENDIF 
     535      Agrif_UseSpecialValue = .FALSE. 
     536      !  
     537   END SUBROUTINE Agrif_dta_ts 
     538 
     539   SUBROUTINE Agrif_ssh( kt ) 
     540      !!---------------------------------------------------------------------- 
     541      !!                  ***  ROUTINE Agrif_DYN  *** 
     542      !!----------------------------------------------------------------------   
     543      INTEGER, INTENT(in) ::   kt 
     544      !! 
     545      !!----------------------------------------------------------------------   
     546 
     547      IF( Agrif_Root() )   RETURN 
     548 
     549      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     550         ssha(2,:)=ssha(3,:) 
     551         sshn(2,:)=sshn(3,:) 
     552      ENDIF 
     553 
     554      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     555         ssha(nlci-1,:)=ssha(nlci-2,:) 
     556         sshn(nlci-1,:)=sshn(nlci-2,:) 
     557      ENDIF 
     558 
     559      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     560         ssha(:,2)=ssha(:,3) 
     561         sshn(:,2)=sshn(:,3) 
     562      ENDIF 
     563 
     564      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     565         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
     566         sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     567      ENDIF 
     568 
     569   END SUBROUTINE Agrif_ssh 
     570 
     571   SUBROUTINE Agrif_ssh_ts( jn ) 
     572      !!---------------------------------------------------------------------- 
     573      !!                  ***  ROUTINE Agrif_ssh_ts  *** 
     574      !!----------------------------------------------------------------------   
     575      INTEGER, INTENT(in) ::   jn 
     576      !! 
     577      INTEGER :: ji,jj 
     578      !!----------------------------------------------------------------------   
     579 
     580      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     581         DO jj=1,jpj 
     582            ssha_e(2,jj) = hbdy_w(jj) 
     583         END DO 
     584      ENDIF 
     585 
     586      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     587         DO jj=1,jpj 
     588            ssha_e(nlci-1,jj) = hbdy_e(jj) 
     589         END DO 
     590      ENDIF 
     591 
     592      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     593         DO ji=1,jpi 
     594            ssha_e(ji,2) = hbdy_s(ji) 
     595         END DO 
     596      ENDIF 
     597 
     598      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     599         DO ji=1,jpi 
     600            ssha_e(ji,nlcj-1) = hbdy_n(ji) 
     601         END DO 
     602      ENDIF 
     603 
     604   END SUBROUTINE Agrif_ssh_ts 
     605 
     606# if defined key_zdftke 
     607   SUBROUTINE Agrif_tke 
     608      !!---------------------------------------------------------------------- 
     609      !!                  ***  ROUTINE Agrif_tke  *** 
     610      !!----------------------------------------------------------------------   
     611      REAL(wp) ::   zalpha 
     612      ! 
     613      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 
     614      IF( zalpha > 1. )   zalpha = 1. 
     615       
     616      Agrif_SpecialValue    = 0.e0 
     617      Agrif_UseSpecialValue = .TRUE. 
     618       
     619      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)        
     620               
     621      Agrif_UseSpecialValue = .FALSE. 
     622      ! 
     623   END SUBROUTINE Agrif_tke 
     624# endif 
     625 
     626   SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     627      !!--------------------------------------------- 
     628      !!   *** ROUTINE interptsn *** 
     629      !!--------------------------------------------- 
     630      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     631      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     632      LOGICAL, INTENT(in) :: before 
     633      INTEGER, INTENT(in) :: nb , ndir 
     634      ! 
     635      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     636      INTEGER :: imin, imax, jmin, jmax 
     637      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     638      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     639      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     640 
     641      IF (before) THEN          
     642         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     643      ELSE 
     644         ! 
     645         western_side  = (nb == 1).AND.(ndir == 1) 
     646         eastern_side  = (nb == 1).AND.(ndir == 2) 
     647         southern_side = (nb == 2).AND.(ndir == 1) 
     648         northern_side = (nb == 2).AND.(ndir == 2) 
     649         ! 
     650         zrhox = Agrif_Rhox() 
     651         !  
     652         zalpha1 = ( zrhox - 1. ) * 0.5 
     653         zalpha2 = 1. - zalpha1 
     654         !  
     655         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     656         zalpha4 = 1. - zalpha3 
     657         !  
     658         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     659         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     660         zalpha5 = 1. - zalpha6 - zalpha7 
     661         ! 
     662         imin = i1 
     663         imax = i2 
     664         jmin = j1 
     665         jmax = j2 
     666         !  
     667         ! Remove CORNERS 
     668         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     669         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     670         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     671         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     672         ! 
     673         IF( eastern_side) THEN 
     674            DO jn = 1, jpts 
     675               tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     676               DO jk = 1, jpkm1 
     677                  DO jj = jmin,jmax 
     678                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     679                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     680                     ELSE 
     681                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     682                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     683                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
     684                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     685                        ENDIF 
     686                     ENDIF 
     687                  END DO 
     688               END DO 
     689            ENDDO 
     690         ENDIF 
     691         !  
     692         IF( northern_side ) THEN             
     693            DO jn = 1, jpts 
     694               tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     695               DO jk = 1, jpkm1 
     696                  DO ji = imin,imax 
     697                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     698                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     699                     ELSE 
     700                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     701                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     702                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
     703                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     704                        ENDIF 
     705                     ENDIF 
     706                  END DO 
     707               END DO 
     708            ENDDO 
     709         ENDIF 
     710         ! 
     711         IF( western_side) THEN             
     712            DO jn = 1, jpts 
     713               tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     714               DO jk = 1, jpkm1 
     715                  DO jj = jmin,jmax 
     716                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     717                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     718                     ELSE 
     719                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     720                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     721                           tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     722                        ENDIF 
     723                     ENDIF 
     724                  END DO 
     725               END DO 
     726            END DO 
     727         ENDIF 
     728         ! 
     729         IF( southern_side ) THEN            
     730            DO jn = 1, jpts 
     731               tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     732               DO jk=1,jpk       
     733                  DO ji=imin,imax 
     734                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     735                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     736                     ELSE 
     737                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     738                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     739                           tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     740                        ENDIF 
     741                     ENDIF 
     742                  END DO 
     743               END DO 
     744            ENDDO 
     745         ENDIF 
     746         ! 
     747         ! Treatment of corners 
     748         !  
     749         ! East south 
     750         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     751            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     752         ENDIF 
     753         ! East north 
     754         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     755            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     756         ENDIF 
     757         ! West south 
     758         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     759            tsa(2,2,:,:) = ptab(2,2,:,:) 
     760         ENDIF 
     761         ! West north 
     762         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     763            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     764         ENDIF 
     765         ! 
     766      ENDIF 
     767      ! 
     768   END SUBROUTINE interptsn 
     769 
     770   SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 
     771      !!---------------------------------------------------------------------- 
     772      !!                  ***  ROUTINE interpsshn  *** 
     773      !!----------------------------------------------------------------------   
     774      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     775      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     776      LOGICAL, INTENT(in) :: before 
     777      INTEGER, INTENT(in) :: nb , ndir 
     778      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     779      !!----------------------------------------------------------------------   
     780      ! 
     781      IF( before) THEN 
     782         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     783      ELSE 
     784         western_side  = (nb == 1).AND.(ndir == 1) 
     785         eastern_side  = (nb == 1).AND.(ndir == 2) 
     786         southern_side = (nb == 2).AND.(ndir == 1) 
     787         northern_side = (nb == 2).AND.(ndir == 2) 
     788         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     789         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
     790         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     791         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
     792      ENDIF 
     793      ! 
     794   END SUBROUTINE interpsshn 
     795 
     796   SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 
     797      !!--------------------------------------------- 
     798      !!   *** ROUTINE interpun *** 
     799      !!---------------------------------------------     
     800      !! 
     801      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     802      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     803      LOGICAL, INTENT(in) :: before 
     804      !! 
     805      INTEGER :: ji,jj,jk 
     806      REAL(wp) :: zrhoy  
     807      !!---------------------------------------------     
     808      ! 
     809      IF (before) THEN  
     810         DO jk=1,jpk 
     811            DO jj=j1,j2 
     812               DO ji=i1,i2 
     813                  ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
     814                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 
     815               END DO 
     816            END DO 
     817         END DO 
     818      ELSE 
     819         zrhoy = Agrif_Rhoy() 
     820         DO jk=1,jpkm1 
     821            DO jj=j1,j2 
     822               ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 
     823               ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 
     824            END DO 
     825         END DO 
     826      ENDIF 
     827      !  
     828   END SUBROUTINE interpun 
     829 
     830 
     831   SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 
     832      !!--------------------------------------------- 
     833      !!   *** ROUTINE interpun *** 
     834      !!---------------------------------------------     
     835      ! 
     836      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     837      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     838      LOGICAL, INTENT(in) :: before 
     839      ! 
     840      INTEGER :: ji,jj 
     841      REAL(wp) :: ztref 
     842      REAL(wp) :: zrhoy  
     843      !!---------------------------------------------     
     844      ! 
     845      ztref = 1. 
     846 
     847      IF (before) THEN  
     848         DO jj=j1,j2 
     849            DO ji=i1,MIN(i2,nlci-1) 
     850               ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
     851            END DO 
     852         END DO 
     853      ELSE 
     854         zrhoy = Agrif_Rhoy() 
     855         DO jj=j1,j2 
     856            laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 
     857         END DO 
     858      ENDIF 
     859      !  
     860   END SUBROUTINE interpun2d 
     861 
     862 
     863   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
     864      !!--------------------------------------------- 
     865      !!   *** ROUTINE interpvn *** 
     866      !!---------------------------------------------     
     867      ! 
     868      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     869      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     870      LOGICAL, INTENT(in) :: before 
     871      ! 
     872      INTEGER :: ji,jj,jk 
     873      REAL(wp) :: zrhox  
     874      !!---------------------------------------------     
     875      !       
     876      IF (before) THEN           
     877         !interpv entre 1 et k2 et interpv2d en jpkp1 
     878         DO jk=k1,jpk 
     879            DO jj=j1,j2 
     880               DO ji=i1,i2 
     881                  ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
     882                  ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
     883               END DO 
     884            END DO 
     885         END DO 
     886      ELSE           
     887         zrhox= Agrif_Rhox() 
     888         DO jk=1,jpkm1 
     889            DO jj=j1,j2 
     890               va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 
     891               va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 
     892            END DO 
     893         END DO 
     894      ENDIF 
     895      !         
     896   END SUBROUTINE interpvn 
     897 
     898   SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
     899      !!--------------------------------------------- 
     900      !!   *** ROUTINE interpvn *** 
     901      !!---------------------------------------------     
     902      ! 
     903      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     904      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     905      LOGICAL, INTENT(in) :: before 
     906      ! 
     907      INTEGER :: ji,jj 
     908      REAL(wp) :: zrhox  
     909      REAL(wp) :: ztref 
     910      !!---------------------------------------------     
     911      !  
     912      ztref = 1.     
     913      IF (before) THEN  
     914         !interpv entre 1 et k2 et interpv2d en jpkp1 
     915         DO jj=j1,MIN(j2,nlcj-1) 
     916            DO ji=i1,i2 
     917               ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
     918            END DO 
     919         END DO 
     920      ELSE            
     921         zrhox = Agrif_Rhox() 
     922         DO ji=i1,i2 
     923            laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
     924         END DO 
     925      ENDIF 
     926      !       
     927   END SUBROUTINE interpvn2d 
     928 
     929   SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     930      !!---------------------------------------------------------------------- 
     931      !!                  ***  ROUTINE interpunb  *** 
     932      !!----------------------------------------------------------------------   
     933      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     934      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     935      LOGICAL, INTENT(in) :: before 
     936      INTEGER, INTENT(in) :: nb , ndir 
     937      !! 
     938      INTEGER :: ji,jj 
     939      REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 
     940      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     941      !!----------------------------------------------------------------------   
     942      ! 
     943      IF (before) THEN  
     944         DO jj=j1,j2 
     945            DO ji=i1,i2 
     946               ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
     947            END DO 
     948         END DO 
     949      ELSE 
     950         western_side  = (nb == 1).AND.(ndir == 1) 
     951         eastern_side  = (nb == 1).AND.(ndir == 2) 
     952         southern_side = (nb == 2).AND.(ndir == 1) 
     953         northern_side = (nb == 2).AND.(ndir == 2) 
     954         zrhoy = Agrif_Rhoy() 
     955         zrhot = Agrif_rhot() 
     956         ! Time indexes bounds for integration 
     957         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     958         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     959         ! Polynomial interpolation coefficients: 
     960         IF( bdy_tinterp == 1 ) THEN 
     961            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     962                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     963         ELSEIF( bdy_tinterp == 2 ) THEN 
     964            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     965                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     966 
     967         ELSE 
     968            ztcoeff = 1 
     969         ENDIF 
     970         !    
     971         IF(western_side) THEN 
     972            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     973         ENDIF 
     974         IF(eastern_side) THEN 
     975            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     976         ENDIF 
     977         IF(southern_side) THEN 
     978            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     979         ENDIF 
     980         IF(northern_side) THEN 
     981            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     982         ENDIF 
     983         !             
     984         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     985            IF(western_side) THEN 
     986               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     987                     &                                  * umask(i1,j1:j2,1) 
     988            ENDIF 
     989            IF(eastern_side) THEN 
     990               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
     991                     &                                  * umask(i1,j1:j2,1) 
     992            ENDIF 
     993            IF(southern_side) THEN 
     994               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     995                     &                                  * umask(i1:i2,j1,1) 
     996            ENDIF 
     997            IF(northern_side) THEN 
     998               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
     999                     &                                  * umask(i1:i2,j1,1) 
     1000            ENDIF 
     1001         ENDIF 
     1002      ENDIF 
     1003      !  
     1004   END SUBROUTINE interpunb 
     1005 
     1006   SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1007      !!---------------------------------------------------------------------- 
     1008      !!                  ***  ROUTINE interpvnb  *** 
     1009      !!----------------------------------------------------------------------   
     1010      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1011      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1012      LOGICAL, INTENT(in) :: before 
     1013      INTEGER, INTENT(in) :: nb , ndir 
     1014      !! 
     1015      INTEGER :: ji,jj 
     1016      REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff    
     1017      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1018      !!----------------------------------------------------------------------   
     1019      !  
     1020      IF (before) THEN  
     1021         DO jj=j1,j2 
     1022            DO ji=i1,i2 
     1023               ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj)  
     1024            END DO 
     1025         END DO 
     1026      ELSE 
     1027         western_side  = (nb == 1).AND.(ndir == 1) 
     1028         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1029         southern_side = (nb == 2).AND.(ndir == 1) 
     1030         northern_side = (nb == 2).AND.(ndir == 2) 
     1031         zrhox = Agrif_Rhox() 
     1032         zrhot = Agrif_rhot() 
     1033         ! Time indexes bounds for integration 
     1034         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1035         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
     1036         IF( bdy_tinterp == 1 ) THEN 
     1037            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     1038                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     1039         ELSEIF( bdy_tinterp == 2 ) THEN 
     1040            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     1041                  &      - zt0        * (       zt0 - 1._wp)**2._wp )  
     1042 
     1043         ELSE 
     1044            ztcoeff = 1 
     1045         ENDIF 
     1046         ! 
     1047         IF(western_side) THEN 
     1048            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1049         ENDIF 
     1050         IF(eastern_side) THEN 
     1051            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
     1052         ENDIF 
     1053         IF(southern_side) THEN 
     1054            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
     1055         ENDIF 
     1056         IF(northern_side) THEN 
     1057            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
     1058         ENDIF 
     1059         !             
     1060         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
     1061            IF(western_side) THEN 
     1062               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1063                     &                                  * vmask(i1,j1:j2,1) 
     1064            ENDIF 
     1065            IF(eastern_side) THEN 
     1066               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
     1067                     &                                  * vmask(i1,j1:j2,1) 
     1068            ENDIF 
     1069            IF(southern_side) THEN 
     1070               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1071                     &                                  * vmask(i1:i2,j1,1) 
     1072            ENDIF 
     1073            IF(northern_side) THEN 
     1074               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
     1075                     &                                  * vmask(i1:i2,j1,1) 
     1076            ENDIF 
     1077         ENDIF 
     1078      ENDIF 
     1079      ! 
     1080   END SUBROUTINE interpvnb 
     1081 
     1082   SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1083      !!---------------------------------------------------------------------- 
     1084      !!                  ***  ROUTINE interpub2b  *** 
     1085      !!----------------------------------------------------------------------   
     1086      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1087      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1088      LOGICAL, INTENT(in) :: before 
     1089      INTEGER, INTENT(in) :: nb , ndir 
     1090      !! 
     1091      INTEGER :: ji,jj 
     1092      REAL(wp) :: zrhot, zt0, zt1,zat 
     1093      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1094      !!----------------------------------------------------------------------   
     1095      IF( before ) THEN 
     1096         DO jj=j1,j2 
     1097            DO ji=i1,i2 
     1098               ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
     1099            END DO 
     1100         END DO 
     1101      ELSE 
     1102         western_side  = (nb == 1).AND.(ndir == 1) 
     1103         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1104         southern_side = (nb == 2).AND.(ndir == 1) 
     1105         northern_side = (nb == 2).AND.(ndir == 2) 
     1106         zrhot = Agrif_rhot() 
    7281107         ! Time indexes bounds for integration 
    7291108         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    7301109         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    731  
    7321110         ! Polynomial interpolation coefficients: 
    733          zaa = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    734                  &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    735          zab = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    736                  &      - zt0        * (       zt0 - 1._wp)**2._wp ) 
    7371111         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    738                  &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    739  
    740          ! Do time interpolation 
    741          IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    742             DO jj=1,jpj 
    743                zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 
    744                zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 
    745             END DO 
    746          ENDIF 
    747          IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    748             DO jj=1,jpj 
    749                zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 
    750                zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 
    751             END DO 
    752          ENDIF 
    753          IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    754             DO ji=1,jpi 
    755                zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 
    756                zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 
    757             END DO 
    758          ENDIF 
    759          IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    760             DO ji=1,jpi 
    761                zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 
    762                zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 
    763             END DO 
    764          ENDIF 
    765          CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
    766  
    767       ELSE ! Linear interpolation 
    768          zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 
    769          CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 
    770          CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 
    771       ENDIF 
    772       Agrif_UseSpecialValue = .FALSE. 
    773  
    774       ! Fill boundary data arrays: 
    775       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    776          DO jj=1,jpj 
    777                ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 
    778                vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 
    779                hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 
    780          END DO 
    781       ENDIF 
    782  
    783       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    784          DO jj=1,jpj 
    785                ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 
    786                vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 
    787                hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 
    788          END DO 
    789       ENDIF 
    790  
    791       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    792          DO ji=1,jpi 
    793                ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 
    794                vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 
    795                hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 
    796          END DO 
    797       ENDIF 
    798  
    799       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    800          DO ji=1,jpi 
    801             ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 
    802             vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 
    803             hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 
    804          END DO 
    805       ENDIF 
    806  
    807       CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 
    808  
    809    END SUBROUTINE Agrif_dta_ts 
    810  
    811    SUBROUTINE Agrif_ssh( kt ) 
    812       !!---------------------------------------------------------------------- 
    813       !!                  ***  ROUTINE Agrif_DYN  *** 
    814       !!----------------------------------------------------------------------   
    815       INTEGER, INTENT(in) ::   kt 
    816       !! 
    817       !!----------------------------------------------------------------------   
    818  
    819       IF( Agrif_Root() )   RETURN 
    820  
    821  
    822       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    823          ssha(2,:)=ssha(3,:) 
    824          sshn(2,:)=sshn(3,:) 
    825       ENDIF 
    826  
    827       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    828          ssha(nlci-1,:)=ssha(nlci-2,:) 
    829          sshn(nlci-1,:)=sshn(nlci-2,:)         
    830       ENDIF 
    831  
    832       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    833          ssha(:,2)=ssha(:,3) 
    834          sshn(:,2)=sshn(:,3) 
    835       ENDIF 
    836  
    837       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    838          ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    839          sshn(:,nlcj-1)=sshn(:,nlcj-2)                 
    840       ENDIF 
    841  
    842    END SUBROUTINE Agrif_ssh 
    843  
    844    SUBROUTINE Agrif_ssh_ts( jn ) 
    845       !!---------------------------------------------------------------------- 
    846       !!                  ***  ROUTINE Agrif_ssh_ts  *** 
    847       !!----------------------------------------------------------------------   
    848       INTEGER, INTENT(in) ::   jn 
     1112               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1113         !  
     1114         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1115         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1116         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1117         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1118      ENDIF 
     1119      !  
     1120   END SUBROUTINE interpub2b 
     1121 
     1122   SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1123      !!---------------------------------------------------------------------- 
     1124      !!                  ***  ROUTINE interpvb2b  *** 
     1125      !!----------------------------------------------------------------------   
     1126      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     1127      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
     1128      LOGICAL, INTENT(in) :: before 
     1129      INTEGER, INTENT(in) :: nb , ndir 
    8491130      !! 
    8501131      INTEGER :: ji,jj 
    851       !!----------------------------------------------------------------------   
    852  
    853       IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    854          DO jj=1,jpj 
    855             ssha_e(2,jj) = hbdy_w(jj) 
    856          END DO 
    857       ENDIF 
    858  
    859       IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    860          DO jj=1,jpj 
    861             ssha_e(nlci-1,jj) = hbdy_e(jj) 
    862          END DO 
    863       ENDIF 
    864  
    865       IF((nbondj == -1).OR.(nbondj == 2)) THEN 
    866          DO ji=1,jpi 
    867             ssha_e(ji,2) = hbdy_s(ji) 
    868          END DO 
    869       ENDIF 
    870  
    871       IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    872          DO ji=1,jpi 
    873             ssha_e(ji,nlcj-1) = hbdy_n(ji) 
    874          END DO 
    875       ENDIF 
    876  
    877    END SUBROUTINE Agrif_ssh_ts 
    878  
    879    SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 
    880       !!---------------------------------------------------------------------- 
    881       !!                  ***  ROUTINE interpsshn  *** 
    882       !!----------------------------------------------------------------------   
    883       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    884       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    885       !! 
    886       INTEGER :: ji,jj 
    887       !!----------------------------------------------------------------------   
    888  
    889       tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
    890  
    891    END SUBROUTINE interpsshn 
    892  
    893    SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 
    894       !!---------------------------------------------------------------------- 
    895       !!                  ***  ROUTINE interpu  *** 
    896       !!----------------------------------------------------------------------   
    897       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    898       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    899       !! 
    900       INTEGER :: ji,jj,jk 
    901       !!----------------------------------------------------------------------   
    902  
    903       DO jk=k1,k2 
     1132      REAL(wp) :: zrhot, zt0, zt1,zat 
     1133      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
     1134      !!----------------------------------------------------------------------   
     1135      ! 
     1136      IF( before ) THEN 
    9041137         DO jj=j1,j2 
    9051138            DO ji=i1,i2 
    906                tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    907                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 
    908             END DO 
    909          END DO 
    910       END DO 
    911    END SUBROUTINE interpu 
    912  
    913  
    914    SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 
    915       !!---------------------------------------------------------------------- 
    916       !!                  ***  ROUTINE interpu2d  *** 
    917       !!----------------------------------------------------------------------   
    918       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    919       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    920       !! 
    921       INTEGER :: ji,jj 
    922       !!----------------------------------------------------------------------   
    923  
    924       DO jj=j1,j2 
    925          DO ji=i1,i2 
    926             tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 
    927                * umask(ji,jj,1) 
    928          END DO 
    929       END DO 
    930  
    931    END SUBROUTINE interpu2d 
    932  
    933  
    934    SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 
    935       !!---------------------------------------------------------------------- 
    936       !!                  ***  ROUTINE interpv  *** 
    937       !!----------------------------------------------------------------------   
     1139               ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
     1140            END DO 
     1141         END DO 
     1142      ELSE       
     1143         western_side  = (nb == 1).AND.(ndir == 1) 
     1144         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1145         southern_side = (nb == 2).AND.(ndir == 1) 
     1146         northern_side = (nb == 2).AND.(ndir == 2) 
     1147         zrhot = Agrif_rhot() 
     1148         ! Time indexes bounds for integration 
     1149         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     1150         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     1151         ! Polynomial interpolation coefficients: 
     1152         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
     1153               &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     1154         ! 
     1155         IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
     1156         IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
     1157         IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
     1158         IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
     1159      ENDIF 
     1160      !       
     1161   END SUBROUTINE interpvb2b 
     1162 
     1163   SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1164      !!---------------------------------------------------------------------- 
     1165      !!                  ***  ROUTINE interpe3t  *** 
     1166      !!----------------------------------------------------------------------   
     1167      !  
    9381168      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    939       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    940       !! 
     1169      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1170      LOGICAL :: before 
     1171      INTEGER, INTENT(in) :: nb , ndir 
     1172      ! 
    9411173      INTEGER :: ji, jj, jk 
    942       !!----------------------------------------------------------------------   
    943  
    944       DO jk=k1,k2 
    945          DO jj=j1,j2 
    946             DO ji=i1,i2 
    947                tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    948                tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 
    949             END DO 
    950          END DO 
    951       END DO 
    952  
    953    END SUBROUTINE interpv 
    954  
    955  
    956    SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 
    957       !!---------------------------------------------------------------------- 
    958       !!                  ***  ROUTINE interpu2d  *** 
    959       !!----------------------------------------------------------------------   
    960       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    961       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    962       !! 
    963       INTEGER :: ji,jj 
    964       !!----------------------------------------------------------------------   
    965  
    966       DO jj=j1,j2 
    967          DO ji=i1,i2 
    968             tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 
    969                * vmask(ji,jj,1) 
    970          END DO 
    971       END DO 
    972  
    973    END SUBROUTINE interpv2d 
    974  
    975    SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 
    976       !!---------------------------------------------------------------------- 
    977       !!                  ***  ROUTINE interpunb  *** 
    978       !!----------------------------------------------------------------------   
    979       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    980       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    981       !! 
    982       INTEGER :: ji,jj 
    983       !!----------------------------------------------------------------------   
    984  
    985       DO jj=j1,j2 
    986          DO ji=i1,i2 
    987             tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
    988          END DO 
    989       END DO 
    990  
    991    END SUBROUTINE interpunb 
    992  
    993    SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 
    994       !!---------------------------------------------------------------------- 
    995       !!                  ***  ROUTINE interpvnb  *** 
    996       !!----------------------------------------------------------------------   
    997       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    998       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    999       !! 
    1000       INTEGER :: ji,jj 
    1001       !!----------------------------------------------------------------------   
    1002  
    1003       DO jj=j1,j2 
    1004          DO ji=i1,i2 
    1005             tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 
    1006          END DO 
    1007       END DO 
    1008  
    1009    END SUBROUTINE interpvnb 
    1010  
    1011    SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 
    1012       !!---------------------------------------------------------------------- 
    1013       !!                  ***  ROUTINE interpub2b  *** 
    1014       !!----------------------------------------------------------------------   
    1015       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1016       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1017       !! 
    1018       INTEGER :: ji,jj 
    1019       !!----------------------------------------------------------------------   
    1020  
    1021       DO jj=j1,j2 
    1022          DO ji=i1,i2 
    1023             tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
    1024          END DO 
    1025       END DO 
    1026  
    1027    END SUBROUTINE interpub2b 
    1028  
    1029    SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 
    1030       !!---------------------------------------------------------------------- 
    1031       !!                  ***  ROUTINE interpvb2b  *** 
    1032       !!----------------------------------------------------------------------   
    1033       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1034       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1035       !! 
    1036       INTEGER :: ji,jj 
    1037       !!----------------------------------------------------------------------   
    1038  
    1039       DO jj=j1,j2 
    1040          DO ji=i1,i2 
    1041             tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
    1042          END DO 
    1043       END DO 
    1044  
    1045    END SUBROUTINE interpvb2b 
     1174      LOGICAL :: western_side, eastern_side, northern_side, southern_side 
     1175      REAL(wp) :: ztmpmsk       
     1176      !!----------------------------------------------------------------------   
     1177      !     
     1178      IF (before) THEN 
     1179         DO jk=k1,k2 
     1180            DO jj=j1,j2 
     1181               DO ji=i1,i2 
     1182                  ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
     1183               END DO 
     1184            END DO 
     1185         END DO 
     1186      ELSE 
     1187         western_side  = (nb == 1).AND.(ndir == 1) 
     1188         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1189         southern_side = (nb == 2).AND.(ndir == 1) 
     1190         northern_side = (nb == 2).AND.(ndir == 2) 
     1191 
     1192         DO jk=k1,k2 
     1193            DO jj=j1,j2 
     1194               DO ji=i1,i2 
     1195                  ! Get velocity mask at boundary edge points: 
     1196                  IF (western_side)  ztmpmsk = umask(ji    ,jj    ,1) 
     1197                  IF (eastern_side)  ztmpmsk = umask(nlci-2,jj    ,1) 
     1198                  IF (northern_side) ztmpmsk = vmask(ji    ,nlcj-2,1) 
     1199                  IF (southern_side) ztmpmsk = vmask(ji    ,2     ,1) 
     1200 
     1201                  IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 
     1202                     IF (western_side) THEN 
     1203                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1204                     ELSEIF (eastern_side) THEN 
     1205                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1206                     ELSEIF (southern_side) THEN 
     1207                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1208                     ELSEIF (northern_side) THEN 
     1209                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
     1210                     ENDIF 
     1211                     WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
     1212                     kindic_agr = kindic_agr + 1 
     1213                  ENDIF 
     1214               END DO 
     1215            END DO 
     1216         END DO 
     1217 
     1218      ENDIF 
     1219      !  
     1220   END SUBROUTINE interpe3t 
     1221 
     1222   SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1223      !!---------------------------------------------------------------------- 
     1224      !!                  ***  ROUTINE interpumsk  *** 
     1225      !!----------------------------------------------------------------------   
     1226      !  
     1227      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1228      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1229      LOGICAL :: before 
     1230      INTEGER, INTENT(in) :: nb , ndir 
     1231      ! 
     1232      INTEGER :: ji, jj, jk 
     1233      LOGICAL :: western_side, eastern_side    
     1234      !!----------------------------------------------------------------------   
     1235      !     
     1236      IF (before) THEN 
     1237         DO jk=k1,k2 
     1238            DO jj=j1,j2 
     1239               DO ji=i1,i2 
     1240                  ptab(ji,jj,jk) = umask(ji,jj,jk) 
     1241               END DO 
     1242            END DO 
     1243         END DO 
     1244      ELSE 
     1245 
     1246         western_side  = (nb == 1).AND.(ndir == 1) 
     1247         eastern_side  = (nb == 1).AND.(ndir == 2) 
     1248         DO jk=k1,k2 
     1249            DO jj=j1,j2 
     1250               DO ji=i1,i2 
     1251                   ! Velocity mask at boundary edge points: 
     1252                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
     1253                     IF (western_side) THEN 
     1254                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1255                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1256                        kindic_agr = kindic_agr + 1 
     1257                     ELSEIF (eastern_side) THEN 
     1258                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1259                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
     1260                        kindic_agr = kindic_agr + 1 
     1261                     ENDIF 
     1262                  ENDIF 
     1263               END DO 
     1264            END DO 
     1265         END DO 
     1266 
     1267      ENDIF 
     1268      !  
     1269   END SUBROUTINE interpumsk 
     1270 
     1271   SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
     1272      !!---------------------------------------------------------------------- 
     1273      !!                  ***  ROUTINE interpvmsk  *** 
     1274      !!----------------------------------------------------------------------   
     1275      !  
     1276      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1277      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1278      LOGICAL :: before 
     1279      INTEGER, INTENT(in) :: nb , ndir 
     1280      ! 
     1281      INTEGER :: ji, jj, jk 
     1282      LOGICAL :: northern_side, southern_side      
     1283      !!----------------------------------------------------------------------   
     1284      !     
     1285      IF (before) THEN 
     1286         DO jk=k1,k2 
     1287            DO jj=j1,j2 
     1288               DO ji=i1,i2 
     1289                  ptab(ji,jj,jk) = vmask(ji,jj,jk) 
     1290               END DO 
     1291            END DO 
     1292         END DO 
     1293      ELSE 
     1294 
     1295         southern_side = (nb == 2).AND.(ndir == 1) 
     1296         northern_side = (nb == 2).AND.(ndir == 2) 
     1297         DO jk=k1,k2 
     1298            DO jj=j1,j2 
     1299               DO ji=i1,i2 
     1300                   ! Velocity mask at boundary edge points: 
     1301                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
     1302                     IF (southern_side) THEN 
     1303                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1304                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1305                        kindic_agr = kindic_agr + 1 
     1306                     ELSEIF (northern_side) THEN 
     1307                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
     1308                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
     1309                        kindic_agr = kindic_agr + 1 
     1310                     ENDIF 
     1311                  ENDIF 
     1312               END DO 
     1313            END DO 
     1314         END DO 
     1315 
     1316      ENDIF 
     1317      !  
     1318   END SUBROUTINE interpvmsk 
     1319 
     1320# if defined key_zdftke 
     1321 
     1322   SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
     1323      !!---------------------------------------------------------------------- 
     1324      !!                  ***  ROUTINE interavm  *** 
     1325      !!----------------------------------------------------------------------   
     1326      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     1327      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     1328      LOGICAL, INTENT(in) :: before 
     1329      !!----------------------------------------------------------------------   
     1330      !       
     1331      IF( before) THEN 
     1332         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     1333      ELSE 
     1334         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
     1335      ENDIF 
     1336      ! 
     1337   END SUBROUTINE interpavm 
     1338 
     1339# endif /* key_zdftke */ 
    10461340 
    10471341#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

    r4153 r7256  
    11#define SPONGE && define SPONGE_TOP 
    22 
    3 Module agrif_opa_sponge 
     3MODULE agrif_opa_sponge 
    44#if defined key_agrif  && ! defined key_offline 
    55   USE par_oce 
    … …  
    99   USE agrif_oce 
    1010   USE wrk_nemo   
     11   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1112 
    1213   IMPLICIT NONE 
    1314   PRIVATE 
    1415 
    15    PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn, interptsn, interpun, interpvn 
    16  
    17   !! * Substitutions 
     16   PUBLIC Agrif_Sponge, Agrif_Sponge_Tra, Agrif_Sponge_Dyn 
     17   PUBLIC interptsn_sponge, interpun_sponge, interpvn_sponge 
     18 
     19   !! * Substitutions 
    1820#  include "domzgr_substitute.h90" 
    1921   !!---------------------------------------------------------------------- 
    … …  
    2325   !!---------------------------------------------------------------------- 
    2426 
    25    CONTAINS 
     27CONTAINS 
    2628 
    2729   SUBROUTINE Agrif_Sponge_Tra 
    … …  
    3032      !!--------------------------------------------- 
    3133      !! 
    32       INTEGER :: ji,jj,jk,jn 
    3334      REAL(wp) :: timecoeff 
    34       REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
    35       REAL(wp), POINTER, DIMENSION(:,:    ) :: ztu, ztv 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    37       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: tsbdiff 
    3835 
    3936#if defined SPONGE 
    40       CALL wrk_alloc( jpi, jpj, ztu, ztv ) 
    41       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    42  
    4337      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    4438 
     39      CALL Agrif_Sponge 
    4540      Agrif_SpecialValue=0. 
    4641      Agrif_UseSpecialValue = .TRUE. 
    47       ztab = 0.e0 
    48       CALL Agrif_Bc_Variable(ztab, tsa_id,calledweight=timecoeff,procname=interptsn) 
     42      tabspongedone_tsn = .FALSE. 
     43 
     44      CALL Agrif_Bc_Variable(tsn_sponge_id,calledweight=timecoeff,procname=interptsn_sponge) 
     45 
    4946      Agrif_UseSpecialValue = .FALSE. 
    50  
    51       tsbdiff(:,:,:,:) = tsb(:,:,:,:) - ztab(:,:,:,:) 
    52  
    53       CALL Agrif_Sponge 
    54  
    55       DO jn = 1, jpts 
    56          DO jk = 1, jpkm1 
    57             ! 
    58             DO jj = 1, jpjm1 
    59                DO ji = 1, jpim1 
    60                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    61                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    62                   ztu(ji,jj) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    63                   ztv(ji,jj) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
    64                ENDDO 
    65             ENDDO 
    66  
    67             DO jj = 2, jpjm1 
    68                DO ji = 2, jpim1 
    69                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    70                   ! horizontal diffusive trends 
    71                   ztsa = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  )   & 
    72                   &              + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
    73                   ! add it to the general tracer trends 
    74                   tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
    75                END DO 
    76             END DO 
    77             ! 
    78          ENDDO 
    79       ENDDO 
    80  
    81       CALL wrk_dealloc( jpi, jpj, ztu, ztv ) 
    82       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab, tsbdiff  ) 
    8347#endif 
    8448 
    … …  
    9054      !!--------------------------------------------- 
    9155      !! 
    92       INTEGER :: ji,jj,jk 
    9356      REAL(wp) :: timecoeff 
    94       REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
    95       REAL(wp), POINTER, DIMENSION(:,:,:) :: ubdiff, vbdiff 
    96       REAL(wp), POINTER, DIMENSION(:,:,:) :: rotdiff, hdivdiff 
    97       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    9857 
    9958#if defined SPONGE 
    100       CALL wrk_alloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    101  
    10259      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    10360 
    10461      Agrif_SpecialValue=0. 
    10562      Agrif_UseSpecialValue = ln_spc_dyn 
    106       ztab = 0.e0 
    107       CALL Agrif_Bc_Variable(ztab, ua_id,calledweight=timecoeff,procname=interpun) 
     63 
     64      tabspongedone_u = .FALSE. 
     65      tabspongedone_v = .FALSE.          
     66      CALL Agrif_Bc_Variable(un_sponge_id,calledweight=timecoeff,procname=interpun_sponge) 
     67 
     68      tabspongedone_u = .FALSE. 
     69      tabspongedone_v = .FALSE. 
     70      CALL Agrif_Bc_Variable(vn_sponge_id,calledweight=timecoeff,procname=interpvn_sponge) 
     71 
    10872      Agrif_UseSpecialValue = .FALSE. 
    109  
    110       ubdiff(:,:,:) = ( ub(:,:,:) - ztab(:,:,:) ) * umask(:,:,:) 
    111  
    112       ztab = 0.e0 
    113       Agrif_SpecialValue=0. 
    114       Agrif_UseSpecialValue = ln_spc_dyn 
    115       CALL Agrif_Bc_Variable(ztab, va_id,calledweight=timecoeff,procname=interpvn) 
    116       Agrif_UseSpecialValue = .FALSE. 
    117  
    118       vbdiff(:,:,:) = ( vb(:,:,:) - ztab(:,:,:) ) * vmask(:,:,:) 
    119  
    120       CALL Agrif_Sponge 
    121  
    122       DO jk = 1,jpkm1 
    123          ubdiff(:,:,jk) = ubdiff(:,:,jk) * spe1ur2(:,:) 
    124          vbdiff(:,:,jk) = vbdiff(:,:,jk) * spe2vr2(:,:) 
    125       ENDDO 
    126        
    127       hdivdiff = 0. 
    128       rotdiff = 0. 
    129  
    130       DO jk = 1, jpkm1                                 ! Horizontal slab 
    131          !                                             ! =============== 
    132  
    133          !                                             ! -------- 
    134          ! Horizontal divergence                       !   div 
    135          !                                             ! -------- 
    136          DO jj = 2, jpjm1 
    137             DO ji = 2, jpim1   ! vector opt. 
    138                zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    139                hdivdiff(ji,jj,jk) =  (  e2u(ji  ,jj  ) * fse3u(ji  ,jj  ,jk) * ubdiff(ji  ,jj  ,jk)     & 
    140                   &                   - e2u(ji-1,jj  ) * fse3u(ji-1,jj  ,jk) * ubdiff(ji-1,jj  ,jk)     & 
    141                   &                   + e1v(ji  ,jj  ) * fse3v(ji  ,jj  ,jk) * vbdiff(ji  ,jj  ,jk)     & 
    142                   &                   - e1v(ji  ,jj-1) * fse3v(ji  ,jj-1,jk) * vbdiff(ji  ,jj-1,jk)  ) * zbtr 
    143             END DO 
    144          END DO 
    145  
    146          DO jj = 1, jpjm1 
    147             DO ji = 1, jpim1   ! vector opt. 
    148                zbtr = spbtr3(ji,jj) * fse3f(ji,jj,jk) 
    149                rotdiff(ji,jj,jk) = (  e2v(ji+1,jj  ) * vbdiff(ji+1,jj  ,jk) - e2v(ji,jj) * vbdiff(ji,jj,jk)    & 
    150                   &                 - e1u(ji  ,jj+1) * ubdiff(ji  ,jj+1,jk) + e1u(ji,jj) * ubdiff(ji,jj,jk)  ) & 
    151                   &               * fmask(ji,jj,jk) * zbtr 
    152             END DO 
    153          END DO 
    154  
    155       ENDDO 
    156  
    157       !                                                ! =============== 
    158       DO jk = 1, jpkm1                                 ! Horizontal slab 
    159          !                                             ! =============== 
    160          DO jj = 2, jpjm1 
    161             DO ji = 2, jpim1   ! vector opt. 
    162                ! horizontal diffusive trends 
    163                zua = - ( rotdiff (ji  ,jj,jk) - rotdiff (ji,jj-1,jk) ) / ( e2u(ji,jj) * fse3u(ji,jj,jk) )   & 
    164                      + ( hdivdiff(ji+1,jj,jk) - hdivdiff(ji,jj  ,jk) ) / e1u(ji,jj) 
    165  
    166                zva = + ( rotdiff (ji,jj  ,jk) - rotdiff (ji-1,jj,jk) ) / ( e1v(ji,jj) * fse3v(ji,jj,jk) )   & 
    167                      + ( hdivdiff(ji,jj+1,jk) - hdivdiff(ji  ,jj,jk) ) / e2v(ji,jj) 
    168                ! add it to the general momentum trends 
    169                ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
    170                va(ji,jj,jk) = va(ji,jj,jk) + zva 
    171             END DO 
    172          END DO 
    173          !                                             ! =============== 
    174       END DO                                           !   End of slab 
    175       !                                                ! =============== 
    176       CALL wrk_dealloc( jpi, jpj, jpk, ztab, ubdiff, vbdiff, rotdiff, hdivdiff ) 
    17773#endif 
    17874 
    … …  
    19995         CALL wrk_alloc( jpi, jpj, ztabramp ) 
    20096 
    201          ispongearea  = 2 + 2 * Agrif_irhox() 
     97         ispongearea  = 2 + nn_sponge_len * Agrif_irhox() 
    20298         ilci = nlci - ispongearea 
    20399         ilcj = nlcj - ispongearea  
    204100         z1spongearea = 1._wp / REAL( ispongearea - 2 ) 
    205          spbtr2(:,:) = 1. / ( e1t(:,:) * e2t(:,:) ) 
    206  
    207          ztabramp(:,:) = 0. 
     101 
     102         ztabramp(:,:) = 0._wp 
    208103 
    209104         IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    … …  
    254149      ! Tracers 
    255150      IF( .NOT. spongedoneT ) THEN 
    256          spe1ur(:,:) = 0. 
    257          spe2vr(:,:) = 0. 
    258  
    259          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    260             spe1ur(2:ispongearea-1,:       ) = visc_tra                                        & 
    261                &                             *    0.5 * (  ztabramp(2:ispongearea-1,:      )   & 
    262                &                                         + ztabramp(3:ispongearea  ,:      ) ) & 
    263                &                             * e2u(2:ispongearea-1,:) / e1u(2:ispongearea-1,:) 
    264  
    265             spe2vr(2:ispongearea  ,1:jpjm1 ) = visc_tra                                        & 
    266                &                             *    0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1)   & 
    267                &                                         + ztabramp(2:ispongearea,2  :jpj  ) ) & 
    268                &                             * e1v(2:ispongearea,1:jpjm1) / e2v(2:ispongearea,1:jpjm1) 
    269          ENDIF 
    270  
    271          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    272             spe1ur(ilci+1:nlci-2,:        ) = visc_tra                                   & 
    273                &                            * 0.5 * (  ztabramp(ilci+1:nlci-2,:      )   &  
    274                &                                     + ztabramp(ilci+2:nlci-1,:      ) ) & 
    275                &                            * e2u(ilci+1:nlci-2,:) / e1u(ilci+1:nlci-2,:) 
    276  
    277             spe2vr(ilci+1:nlci-1,1:jpjm1  )  = visc_tra                                  & 
    278                &                            * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1)   &  
    279                &                                     + ztabramp(ilci+1:nlci-1,2:jpj  ) ) &  
    280                &                            * e1v(ilci+1:nlci-1,1:jpjm1) / e2v(ilci+1:nlci-1,1:jpjm1) 
    281          ENDIF 
    282  
    283          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    284             spe1ur(1:jpim1,2:ispongearea  ) = visc_tra                                     & 
    285                &                            * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  )   &  
    286                &                                     + ztabramp(2:jpi  ,2:ispongearea  ) ) & 
    287                &                            * e2u(1:jpim1,2:ispongearea) / e1u(1:jpim1,2:ispongearea) 
    288     
    289             spe2vr(:      ,2:ispongearea-1) = visc_tra                                     & 
    290                &                            * 0.5 * (  ztabramp(:      ,2:ispongearea-1)   & 
    291                &                                     + ztabramp(:      ,3:ispongearea  ) ) & 
    292                &                            * e1v(:,2:ispongearea-1) / e2v(:,2:ispongearea-1) 
    293          ENDIF 
    294  
    295          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    296             spe1ur(1:jpim1,ilcj+1:nlcj-1) = visc_tra                                   & 
    297                &                          * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1)   & 
    298                &                                   + ztabramp(2:jpi  ,ilcj+1:nlcj-1) ) & 
    299                &                                * e2u(1:jpim1,ilcj+1:nlcj-1) / e1u(1:jpim1,ilcj+1:nlcj-1) 
    300  
    301             spe2vr(:      ,ilcj+1:nlcj-2) = visc_tra                                   & 
    302                &                          * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2)   & 
    303                &                                   + ztabramp(:      ,ilcj+2:nlcj-1) ) & 
    304                &                                * e1v(:,ilcj+1:nlcj-2) / e2v(:,ilcj+1:nlcj-2) 
    305          ENDIF 
     151         fsaht_spu(:,:) = 0._wp 
     152         fsaht_spv(:,:) = 0._wp 
     153         DO jj = 2, jpjm1 
     154            DO ji = 2, jpim1   ! vector opt. 
     155               fsaht_spu(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji+1,jj  )) 
     156               fsaht_spv(ji,jj) = 0.5_wp * visc_tra * (ztabramp(ji,jj) + ztabramp(ji  ,jj+1)) 
     157            END DO 
     158         END DO 
     159 
     160         CALL lbc_lnk( fsaht_spu, 'U', 1. )   ! Lateral boundary conditions 
     161         CALL lbc_lnk( fsaht_spv, 'V', 1. ) 
    306162         spongedoneT = .TRUE. 
    307163      ENDIF 
    … …  
    309165      ! Dynamics 
    310166      IF( .NOT. spongedoneU ) THEN 
    311          spe1ur2(:,:) = 0. 
    312          spe2vr2(:,:) = 0. 
    313  
    314          IF( (nbondi == -1) .OR. (nbondi == 2) ) THEN 
    315             spe1ur2(2:ispongearea-1,:      ) = visc_dyn                                   & 
    316                &                             * 0.5 * (  ztabramp(2:ispongearea-1,:      ) & 
    317                &                                      + ztabramp(3:ispongearea  ,:      ) ) 
    318             spe2vr2(2:ispongearea  ,1:jpjm1) = visc_dyn                                   & 
    319                &                             * 0.5 * (  ztabramp(2:ispongearea  ,1:jpjm1) & 
    320                &                                      + ztabramp(2:ispongearea  ,2:jpj  ) )  
    321          ENDIF 
    322  
    323          IF( (nbondi == 1) .OR. (nbondi == 2) ) THEN 
    324             spe1ur2(ilci+1:nlci-2  ,:      ) = visc_dyn                                   & 
    325                &                             * 0.5 * (  ztabramp(ilci+1:nlci-2, :       ) & 
    326                &                                      + ztabramp(ilci+2:nlci-1, :       ) )                       
    327             spe2vr2(ilci+1:nlci-1  ,1:jpjm1) = visc_dyn                                   & 
    328                &                             * 0.5 * (  ztabramp(ilci+1:nlci-1,1:jpjm1  ) & 
    329                &                                      + ztabramp(ilci+1:nlci-1,2:jpj    ) )  
    330          ENDIF 
    331  
    332          IF( (nbondj == -1) .OR. (nbondj == 2) ) THEN 
    333             spe1ur2(1:jpim1,2:ispongearea  ) = visc_dyn                                   &   
    334                &                             * 0.5 * (  ztabramp(1:jpim1,2:ispongearea  ) & 
    335                &                                      + ztabramp(2:jpi  ,2:ispongearea  ) )  
    336             spe2vr2(:      ,2:ispongearea-1) = visc_dyn                                   & 
    337                &                             * 0.5 * (  ztabramp(:      ,2:ispongearea-1) & 
    338                &                                      + ztabramp(:      ,3:ispongearea  ) ) 
    339          ENDIF 
    340  
    341          IF( (nbondj == 1) .OR. (nbondj == 2) ) THEN 
    342             spe1ur2(1:jpim1,ilcj+1:nlcj-1  ) = visc_dyn                                   & 
    343                &                             * 0.5 * (  ztabramp(1:jpim1,ilcj+1:nlcj-1  ) & 
    344                &                                      + ztabramp(2:jpi  ,ilcj+1:nlcj-1  ) )  
    345             spe2vr2(:      ,ilcj+1:nlcj-2  ) = visc_dyn                                   & 
    346                &                             * 0.5 * (  ztabramp(:      ,ilcj+1:nlcj-2  ) & 
    347                &                                      + ztabramp(:      ,ilcj+2:nlcj-1  ) ) 
    348          ENDIF 
     167         fsahm_spt(:,:) = 0._wp 
     168         fsahm_spf(:,:) = 0._wp 
     169         DO jj = 2, jpjm1 
     170            DO ji = 2, jpim1   ! vector opt. 
     171               fsahm_spt(ji,jj) = visc_dyn * ztabramp(ji,jj) 
     172               fsahm_spf(ji,jj) = 0.25_wp * visc_dyn * ( ztabramp(ji,jj) + ztabramp(ji  ,jj+1) & 
     173                                                     &  +ztabramp(ji,jj) + ztabramp(ji+1,jj  ) ) 
     174            END DO 
     175         END DO 
     176 
     177         CALL lbc_lnk( fsahm_spt, 'T', 1. )   ! Lateral boundary conditions 
     178         CALL lbc_lnk( fsahm_spf, 'F', 1. ) 
    349179         spongedoneU = .TRUE. 
    350          spbtr3(:,:) = 1. / ( e1f(:,:) * e2f(:,:) ) 
    351180      ENDIF 
    352181      ! 
    … …  
    357186   END SUBROUTINE Agrif_Sponge 
    358187 
    359    SUBROUTINE interptsn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    360       !!--------------------------------------------- 
    361       !!   *** ROUTINE interptsn *** 
     188   SUBROUTINE interptsn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     189      !!--------------------------------------------- 
     190      !!   *** ROUTINE interptsn_sponge *** 
    362191      !!--------------------------------------------- 
    363192      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    364193      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    365  
    366       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
    367  
    368    END SUBROUTINE interptsn 
    369  
    370    SUBROUTINE interpun(tabres,i1,i2,j1,j2,k1,k2) 
    371       !!--------------------------------------------- 
    372       !!   *** ROUTINE interpun *** 
    373       !!--------------------------------------------- 
     194      LOGICAL, INTENT(in) :: before 
     195 
     196 
     197      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     198      INTEGER  ::   iku, ikv 
     199      REAL(wp) :: ztsa, zabe1, zabe2, zbtr 
     200      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ztu, ztv 
     201      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::tsbdiff 
     202      ! 
     203      IF (before) THEN 
     204         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
     205      ELSE    
     206    
     207         tsbdiff(:,:,:,:) = tsb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)     
     208         DO jn = 1, jpts             
     209            DO jk = 1, jpkm1 
     210               DO jj = j1,j2-1 
     211                  DO ji = i1,i2-1 
     212                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     213                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     214                     ztu(ji,jj,jk) = zabe1 * ( tsbdiff(ji+1,jj  ,jk,jn) - tsbdiff(ji,jj,jk,jn) )  
     215                     ztv(ji,jj,jk) = zabe2 * ( tsbdiff(ji  ,jj+1,jk,jn) - tsbdiff(ji,jj,jk,jn) ) 
     216                  ENDDO 
     217               ENDDO 
     218 
     219               IF( ln_zps ) THEN      ! set gradient at partial step level 
     220                  DO jj = j1,j2-1 
     221                     DO ji = i1,i2-1 
     222                        ! last level 
     223                        iku = mbku(ji,jj) 
     224                        ikv = mbkv(ji,jj) 
     225                        IF( iku == jk ) THEN 
     226                           ztu(ji,jj,jk) = 0._wp 
     227                        ENDIF 
     228                        IF( ikv == jk ) THEN 
     229                           ztv(ji,jj,jk) = 0._wp 
     230                        ENDIF 
     231                     END DO 
     232                  END DO 
     233               ENDIF 
     234            ENDDO 
     235 
     236            DO jk = 1, jpkm1 
     237               DO jj = j1+1,j2-1 
     238                  DO ji = i1+1,i2-1 
     239 
     240                     IF (.NOT. tabspongedone_tsn(ji,jj)) THEN  
     241                        zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) 
     242                        ! horizontal diffusive trends 
     243                        ztsa = zbtr * (  ztu(ji,jj,jk) - ztu(ji-1,jj,jk) + ztv(ji,jj,jk) - ztv(ji  ,jj-1,jk)  ) 
     244                        ! add it to the general tracer trends 
     245                        tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + ztsa 
     246                     ENDIF 
     247 
     248                  ENDDO 
     249               ENDDO 
     250 
     251            ENDDO 
     252         ENDDO 
     253 
     254         tabspongedone_tsn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     255 
     256      ENDIF 
     257 
     258   END SUBROUTINE interptsn_sponge 
     259 
     260   SUBROUTINE interpun_sponge(tabres,i1,i2,j1,j2,k1,k2, before) 
     261      !!--------------------------------------------- 
     262      !!   *** ROUTINE interpun_sponge *** 
     263      !!---------------------------------------------     
    374264      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    375265      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    376  
    377       tabres(i1:i2,j1:j2,k1:k2) = un(i1:i2,j1:j2,k1:k2) 
    378  
    379    END SUBROUTINE interpun 
    380  
    381    SUBROUTINE interpvn(tabres,i1,i2,j1,j2,k1,k2) 
    382       !!--------------------------------------------- 
    383       !!   *** ROUTINE interpvn *** 
    384       !!--------------------------------------------- 
     266      LOGICAL, INTENT(in) :: before 
     267 
     268      INTEGER :: ji,jj,jk 
     269 
     270      ! sponge parameters  
     271      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     272      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: ubdiff 
     273      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     274      INTEGER :: jmax 
     275      ! 
     276 
     277 
     278      IF (before) THEN 
     279         tabres = un(i1:i2,j1:j2,:) 
     280      ELSE 
     281 
     282         ubdiff(i1:i2,j1:j2,:) = (ub(i1:i2,j1:j2,:) - tabres(:,:,:))*umask(i1:i2,j1:j2,:) 
     283 
     284         DO jk = 1, jpkm1                                 ! Horizontal slab 
     285            !                                             ! =============== 
     286 
     287            !                                             ! -------- 
     288            ! Horizontal divergence                       !   div 
     289            !                                             ! -------- 
     290            DO jj = j1,j2 
     291               DO ji = i1+1,i2   ! vector opt. 
     292                  zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     293                  hdivdiff(ji,jj,jk) = (  e2u(ji  ,jj)*fse3u_n(ji  ,jj,jk) * ubdiff(ji  ,jj,jk) & 
     294                                     &   -e2u(ji-1,jj)*fse3u_n(ji-1,jj,jk) * ubdiff(ji-1,jj,jk) ) * zbtr 
     295               END DO 
     296            END DO 
     297 
     298            DO jj = j1,j2-1 
     299               DO ji = i1,i2   ! vector opt. 
     300                  zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     301                  rotdiff(ji,jj,jk) = (-e1u(ji,jj+1) * ubdiff(ji,jj+1,jk) & 
     302                                       +e1u(ji,jj  ) * ubdiff(ji,jj  ,jk) &  
     303                                    & ) * fmask(ji,jj,jk) * zbtr  
     304               END DO 
     305            END DO 
     306         ENDDO 
     307 
     308         ! 
     309 
     310 
     311 
     312         DO jj = j1+1, j2-1 
     313            DO ji = i1+1, i2-1   ! vector opt. 
     314 
     315               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     316                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     317                     ze2u = rotdiff (ji,jj,jk) 
     318                     ze1v = hdivdiff(ji,jj,jk) 
     319                     ! horizontal diffusive trends 
     320                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) )   & 
     321                           + ( hdivdiff(ji+1,jj,jk) - ze1v  ) / e1u(ji,jj) 
     322 
     323                     ! add it to the general momentum trends 
     324                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     325 
     326                  END DO 
     327               ENDIF 
     328 
     329            END DO 
     330         END DO 
     331 
     332         tabspongedone_u(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     333 
     334         jmax = j2-1 
     335         IF ((nbondj == 1).OR.(nbondj == 2)) jmax = MIN(jmax,nlcj-3) 
     336 
     337         DO jj = j1+1, jmax 
     338            DO ji = i1+1, i2   ! vector opt. 
     339 
     340               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     341                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     342                     ze2u = rotdiff (ji,jj,jk) 
     343                     ze1v = hdivdiff(ji,jj,jk) 
     344 
     345                     ! horizontal diffusive trends 
     346                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) )   & 
     347                           + ( hdivdiff(ji,jj+1,jk) - ze1v  ) / e2v(ji,jj) 
     348 
     349                     ! add it to the general momentum trends 
     350                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     351                  END DO 
     352               ENDIF 
     353 
     354            END DO 
     355         END DO 
     356 
     357 
     358         tabspongedone_v(i1+1:i2,j1+1:jmax) = .TRUE. 
     359 
     360      ENDIF 
     361 
     362 
     363   END SUBROUTINE interpun_sponge 
     364 
     365 
     366   SUBROUTINE interpvn_sponge(tabres,i1,i2,j1,j2,k1,k2, before,nb,ndir) 
     367      !!--------------------------------------------- 
     368      !!   *** ROUTINE interpvn_sponge *** 
     369      !!---------------------------------------------  
    385370      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    386371      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    387  
    388       tabres(i1:i2,j1:j2,k1:k2) = vn(i1:i2,j1:j2,k1:k2) 
    389  
    390    END SUBROUTINE interpvn 
     372      LOGICAL, INTENT(in) :: before 
     373      INTEGER, INTENT(in) :: nb , ndir 
     374 
     375      INTEGER :: ji,jj,jk 
     376 
     377      REAL(wp) :: ze2u, ze1v, zua, zva, zbtr 
     378 
     379      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: vbdiff 
     380      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: rotdiff, hdivdiff 
     381      INTEGER :: imax 
     382      ! 
     383 
     384      IF (before) THEN  
     385         tabres = vn(i1:i2,j1:j2,:) 
     386      ELSE 
     387 
     388         vbdiff(i1:i2,j1:j2,:) = (vb(i1:i2,j1:j2,:) - tabres(:,:,:))*vmask(i1:i2,j1:j2,:) 
     389 
     390         DO jk = 1, jpkm1                                 ! Horizontal slab 
     391            !                                             ! =============== 
     392 
     393            !                                             ! -------- 
     394            ! Horizontal divergence                       !   div 
     395            !                                             ! -------- 
     396            DO jj = j1+1,j2 
     397               DO ji = i1,i2   ! vector opt. 
     398                  zbtr = r1_e12t(ji,jj) / fse3t_n(ji,jj,jk) * fsahm_spt(ji,jj) 
     399                  hdivdiff(ji,jj,jk) = ( e1v(ji,jj  ) * fse3v(ji,jj  ,jk) * vbdiff(ji,jj  ,jk)  & 
     400                                     &  -e1v(ji,jj-1) * fse3v(ji,jj-1,jk) * vbdiff(ji,jj-1,jk)  ) * zbtr 
     401               END DO 
     402            END DO 
     403            DO jj = j1,j2 
     404               DO ji = i1,i2-1   ! vector opt. 
     405                  zbtr = r1_e12f(ji,jj) * fse3f_n(ji,jj,jk) * fsahm_spf(ji,jj) 
     406                  rotdiff(ji,jj,jk) = ( e2v(ji+1,jj) * vbdiff(ji+1,jj,jk) &  
     407                                    &  -e2v(ji  ,jj) * vbdiff(ji  ,jj,jk) & 
     408                                    & ) * fmask(ji,jj,jk) * zbtr 
     409               END DO 
     410            END DO 
     411         ENDDO 
     412 
     413         !                                                ! =============== 
     414         !                                                 
     415 
     416         imax = i2-1 
     417         IF ((nbondi == 1).OR.(nbondi == 2)) imax = MIN(imax,nlci-3) 
     418 
     419         DO jj = j1+1, j2 
     420            DO ji = i1+1, imax   ! vector opt. 
     421               IF (.NOT. tabspongedone_u(ji,jj)) THEN 
     422                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     423                     ze2u = rotdiff (ji,jj,jk) 
     424                     ze1v = hdivdiff(ji,jj,jk) 
     425                     ! horizontal diffusive trends 
     426                     zua = - ( ze2u - rotdiff (ji,jj-1,jk)) / ( e2u(ji,jj) * fse3u_n(ji,jj,jk) ) + ( hdivdiff(ji+1,jj,jk) - ze1v) & 
     427                           / e1u(ji,jj) 
     428 
     429 
     430                     ! add it to the general momentum trends 
     431                     ua(ji,jj,jk) = ua(ji,jj,jk) + zua 
     432                  END DO 
     433 
     434               ENDIF 
     435            END DO 
     436         END DO 
     437 
     438         tabspongedone_u(i1+1:imax,j1+1:j2) = .TRUE. 
     439 
     440         DO jj = j1+1, j2-1 
     441            DO ji = i1+1, i2-1   ! vector opt. 
     442               IF (.NOT. tabspongedone_v(ji,jj)) THEN 
     443                  DO jk = 1, jpkm1                                 ! Horizontal slab 
     444                     ze2u = rotdiff (ji,jj,jk) 
     445                     ze1v = hdivdiff(ji,jj,jk) 
     446                     ! horizontal diffusive trends 
     447 
     448                     zva = + ( ze2u - rotdiff (ji-1,jj,jk)) / ( e1v(ji,jj) * fse3v_n(ji,jj,jk) ) + ( hdivdiff(ji,jj+1,jk) - ze1v) & 
     449                           / e2v(ji,jj) 
     450 
     451                     ! add it to the general momentum trends 
     452                     va(ji,jj,jk) = va(ji,jj,jk) + zva 
     453                  END DO 
     454               ENDIF 
     455            END DO 
     456         END DO 
     457         tabspongedone_v(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     458      ENDIF 
     459 
     460   END SUBROUTINE interpvn_sponge 
    391461 
    392462#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r4491 r7256  
    1 #define TWO_WAY 
    2  
     1#define TWO_WAY        /* TWO WAY NESTING */ 
     2#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 
     3  
    34MODULE agrif_opa_update 
    45#if defined key_agrif  && ! defined key_offline 
    … …  
    1112   USE wrk_nemo   
    1213   USE dynspg_oce 
     14   USE zdf_oce        ! vertical physics: ocean variables  
    1315 
    1416   IMPLICIT NONE 
    1517   PRIVATE 
    1618 
    17    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
    18  
    19    INTEGER, PUBLIC :: nbcline = 0 
    20  
     19   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
     20# if defined key_zdftke 
     21   PUBLIC Agrif_Update_Tke 
     22# endif 
    2123   !!---------------------------------------------------------------------- 
    22    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2325   !! $Id$ 
    2426   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2729CONTAINS 
    2830 
    29    SUBROUTINE Agrif_Update_Tra( kt ) 
     31   RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
    3032      !!--------------------------------------------- 
    3133      !!   *** ROUTINE Agrif_Update_Tra *** 
    3234      !!--------------------------------------------- 
    33       !! 
    34       INTEGER, INTENT(in) :: kt 
    35       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
    36  
    37  
    38       IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 
     35      !  
     36      IF (Agrif_Root()) RETURN 
     37      ! 
     38#if defined TWO_WAY   
     39      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
    4140 
    4241      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4342      Agrif_SpecialValueFineGrid = 0. 
    44  
     43      !  
    4544      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 
    47       ELSE 
    48          CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 
    49       ENDIF 
    50  
     45# if ! defined DECAL_FEEDBACK 
     46         CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
     47# else 
     48         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
     49# endif 
     50      ELSE 
     51# if ! defined DECAL_FEEDBACK 
     52         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
     53# else 
     54         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
     55# endif 
     56      ENDIF 
     57      ! 
    5158      Agrif_UseSpecialValueInUpdate = .FALSE. 
    52  
    53       CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
     59      ! 
     60      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     61         CALL Agrif_ChildGrid_To_ParentGrid() 
     62         CALL Agrif_Update_Tra() 
     63         CALL Agrif_ParentGrid_To_ChildGrid() 
     64      ENDIF 
     65      ! 
    5466#endif 
    55  
     67      ! 
    5668   END SUBROUTINE Agrif_Update_Tra 
    5769 
    58    SUBROUTINE Agrif_Update_Dyn( kt ) 
     70   RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
    5971      !!--------------------------------------------- 
    6072      !!   *** ROUTINE Agrif_Update_Dyn *** 
    6173      !!--------------------------------------------- 
    62       !! 
    63       INTEGER, INTENT(in) :: kt 
    64       REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
    66  
    67  
    68       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 
     74      !  
     75      IF (Agrif_Root()) RETURN 
     76      ! 
    6977#if defined TWO_WAY 
    70       CALL wrk_alloc( jpi, jpj,      ztab2d ) 
    71       CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
    72  
     78      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     79 
     80      Agrif_UseSpecialValueInUpdate = .FALSE. 
     81      Agrif_SpecialValueFineGrid = 0. 
     82      !      
    7383      IF (mod(nbcline,nbclineupdate) == 0) THEN 
    74          CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 
    75          CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 
    76       ELSE 
    77          CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 
    78          CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)          
    79       ENDIF 
    80  
    81       CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 
    82       CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
    83  
    84 #if defined key_dynspg_ts 
     84# if ! defined DECAL_FEEDBACK 
     85         CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
     86         CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
     87# else 
     88         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
     89         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
     90# endif 
     91      ELSE 
     92# if ! defined DECAL_FEEDBACK 
     93         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
     94         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
     95# else 
     96         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
     97         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
     98# endif 
     99      ENDIF 
     100 
     101# if ! defined DECAL_FEEDBACK 
     102      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
     103      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
     104# else 
     105      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
     106      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
     107# endif 
     108 
     109# if defined key_dynspg_ts 
    85110      IF (ln_bt_fw) THEN 
    86111         ! Update time integrated transports 
    87112         IF (mod(nbcline,nbclineupdate) == 0) THEN 
    88             CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 
    89             CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 
     113#  if ! defined DECAL_FEEDBACK 
     114            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
     115            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
     116#  else 
     117            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
     118            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
     119#  endif 
    90120         ELSE 
    91             CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 
    92             CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 
     121#  if ! defined DECAL_FEEDBACK 
     122            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
     123            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
     124#  else 
     125            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
     126            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
     127#  endif 
    93128         ENDIF 
    94       END IF  
     129      END IF 
     130# endif 
     131      ! 
     132      nbcline = nbcline + 1 
     133      ! 
     134      Agrif_UseSpecialValueInUpdate = .TRUE. 
     135      Agrif_SpecialValueFineGrid = 0. 
     136# if ! defined DECAL_FEEDBACK 
     137      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
     138# else 
     139      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
     140# endif 
     141      Agrif_UseSpecialValueInUpdate = .FALSE. 
     142      !  
    95143#endif 
    96  
    97       nbcline = nbcline + 1 
    98  
    99       Agrif_UseSpecialValueInUpdate = .TRUE.  
     144      ! 
     145      ! Do recursive update: 
     146      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
     147         CALL Agrif_ChildGrid_To_ParentGrid() 
     148         CALL Agrif_Update_Dyn() 
     149         CALL Agrif_ParentGrid_To_ChildGrid() 
     150      ENDIF 
     151      ! 
     152   END SUBROUTINE Agrif_Update_Dyn 
     153 
     154# if defined key_zdftke 
     155   SUBROUTINE Agrif_Update_Tke( kt ) 
     156      !!--------------------------------------------- 
     157      !!   *** ROUTINE Agrif_Update_Tke *** 
     158      !!--------------------------------------------- 
     159      !! 
     160      INTEGER, INTENT(in) :: kt 
     161      !        
     162      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
     163#  if defined TWO_WAY 
     164 
     165      Agrif_UseSpecialValueInUpdate = .TRUE. 
    100166      Agrif_SpecialValueFineGrid = 0. 
    101       CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
     167 
     168      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
     169      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
     170      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
     171 
    102172      Agrif_UseSpecialValueInUpdate = .FALSE. 
    103173 
    104       CALL wrk_dealloc( jpi, jpj,      ztab2d ) 
    105       CALL wrk_dealloc( jpi, jpj, jpk, ztab   ) 
    106  
    107 !Done in step 
    108 !      CALL Agrif_ChildGrid_To_ParentGrid() 
    109 !      CALL recompute_diags( kt ) 
    110 !      CALL Agrif_ParentGrid_To_ChildGrid() 
    111  
    112 #endif 
    113  
    114    END SUBROUTINE Agrif_Update_Dyn 
    115  
    116    SUBROUTINE recompute_diags( kt ) 
    117       !!--------------------------------------------- 
    118       !!   *** ROUTINE recompute_diags *** 
    119       !!--------------------------------------------- 
    120       INTEGER, INTENT(in) :: kt 
    121  
    122    END SUBROUTINE recompute_diags 
     174#  endif 
     175       
     176   END SUBROUTINE Agrif_Update_Tke 
     177# endif /* key_zdftke */ 
    123178 
    124179   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    127182      !!--------------------------------------------- 
    128183#  include "domzgr_substitute.h90" 
    129  
    130184      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    131185      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    132       LOGICAL, iNTENT(in) :: before 
    133  
     186      LOGICAL, INTENT(in) :: before 
     187      !! 
    134188      INTEGER :: ji,jj,jk,jn 
    135  
     189      !!--------------------------------------------- 
     190      ! 
    136191      IF (before) THEN 
    137192         DO jn = n1,n2 
    … …  
    146201      ELSE 
    147202         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    148          ! Add asselin part 
     203            ! Add asselin part 
    149204            DO jn = n1,n2 
    150205               DO jk=k1,k2 
    … …  
    153208                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    154209                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    155                               & + atfp * ( tabres(ji,jj,jk,jn) & 
    156                               &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     210                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     211                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    157212                        ENDIF 
    158213                     ENDDO 
    … …  
    161216            ENDDO 
    162217         ENDIF 
    163  
    164218         DO jn = n1,n2 
    165219            DO jk=k1,k2 
    … …  
    174228         END DO 
    175229      ENDIF 
    176  
     230      !  
    177231   END SUBROUTINE updateTS 
    178232 
    … …  
    182236      !!--------------------------------------------- 
    183237#  include "domzgr_substitute.h90" 
    184  
     238      !! 
    185239      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    186240      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    187241      LOGICAL, INTENT(in) :: before 
    188  
     242      !!  
    189243      INTEGER :: ji, jj, jk 
    190244      REAL(wp) :: zrhoy 
    191  
     245      !!--------------------------------------------- 
     246      !  
    192247      IF (before) THEN 
    193248         zrhoy = Agrif_Rhoy() 
    … …  
    209264                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    210265                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    211                        & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     266                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    212267                  ENDIF 
    213268                  ! 
    … …  
    217272         END DO 
    218273      ENDIF 
    219  
     274      !  
    220275   END SUBROUTINE updateu 
    221276 
    … …  
    225280      !!--------------------------------------------- 
    226281#  include "domzgr_substitute.h90" 
    227  
     282      !! 
    228283      INTEGER :: i1,i2,j1,j2,k1,k2 
    229284      INTEGER :: ji,jj,jk 
    230285      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    231286      LOGICAL :: before 
    232  
     287      !! 
    233288      REAL(wp) :: zrhox 
    234  
     289      !!---------------------------------------------       
     290      ! 
    235291      IF (before) THEN 
    236292         zrhox = Agrif_Rhox() 
    … …  
    252308                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    253309                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    254                        & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     310                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    255311                  ENDIF 
    256312                  ! 
    … …  
    260316         END DO 
    261317      ENDIF 
    262  
     318      !  
    263319   END SUBROUTINE updatev 
    264320 
    … …  
    268324      !!--------------------------------------------- 
    269325#  include "domzgr_substitute.h90" 
    270  
     326      !! 
    271327      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    272328      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    273329      LOGICAL, INTENT(in) :: before 
    274  
     330      !!  
    275331      INTEGER :: ji, jj, jk 
    276332      REAL(wp) :: zrhoy 
    277333      REAL(wp) :: zcorr 
    278  
     334      !!--------------------------------------------- 
     335      ! 
    279336      IF (before) THEN 
    280337         zrhoy = Agrif_Rhoy() 
    … …  
    326383         END DO 
    327384      ENDIF 
    328  
     385      ! 
    329386   END SUBROUTINE updateu2d 
    330387 
    … …  
    333390      !!          *** ROUTINE updatev2d *** 
    334391      !!--------------------------------------------- 
    335  
    336392      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    337393      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    338394      LOGICAL, INTENT(in) :: before 
    339  
     395      !!  
    340396      INTEGER :: ji, jj, jk 
    341397      REAL(wp) :: zrhox 
    342398      REAL(wp) :: zcorr 
    343  
     399      !!--------------------------------------------- 
     400      ! 
    344401      IF (before) THEN 
    345402         zrhox = Agrif_Rhox() 
    … …  
    391448         END DO 
    392449      ENDIF 
    393  
     450      !  
    394451   END SUBROUTINE updatev2d 
    395452 
     453 
    396454   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    397455      !!--------------------------------------------- 
    398456      !!          *** ROUTINE updateSSH *** 
    399457      !!--------------------------------------------- 
    400 #  include "domzgr_substitute.h90" 
    401  
    402458      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    403459      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    404460      LOGICAL, INTENT(in) :: before 
    405  
     461      !! 
    406462      INTEGER :: ji, jj 
    407  
     463      !!--------------------------------------------- 
     464      !  
    408465      IF (before) THEN 
    409466         DO jj=j1,j2 
    … …  
    413470         END DO 
    414471      ELSE 
    415  
    416472#if ! defined key_dynspg_ts 
    417473         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    418474            DO jj=j1,j2 
    419475               DO ji=i1,i2 
    420                 sshb(ji,jj) =   sshb(ji,jj) & 
    421                  & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     476                  sshb(ji,jj) =   sshb(ji,jj) & 
     477                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    422478               END DO 
    423479            END DO 
    … …  
    430486         END DO 
    431487      ENDIF 
    432  
     488      ! 
    433489   END SUBROUTINE updateSSH 
    434490 
    … …  
    437493      !!          *** ROUTINE updateub2b *** 
    438494      !!--------------------------------------------- 
    439  
    440495      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    441496      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    442497      LOGICAL, INTENT(in) :: before 
    443  
     498      !! 
    444499      INTEGER :: ji, jj 
    445500      REAL(wp) :: zrhoy 
    446  
     501      !!--------------------------------------------- 
     502      ! 
    447503      IF (before) THEN 
    448504         zrhoy = Agrif_Rhoy() 
    … …  
    460516         END DO 
    461517      ENDIF 
    462  
     518      ! 
    463519   END SUBROUTINE updateub2b 
    464520 
    … …  
    467523      !!          *** ROUTINE updatevb2b *** 
    468524      !!--------------------------------------------- 
    469  
    470525      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    471526      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    472527      LOGICAL, INTENT(in) :: before 
    473  
     528      !! 
    474529      INTEGER :: ji, jj 
    475530      REAL(wp) :: zrhox 
    476  
     531      !!--------------------------------------------- 
     532      ! 
    477533      IF (before) THEN 
    478534         zrhox = Agrif_Rhox() 
    … …  
    490546         END DO 
    491547      ENDIF 
    492  
     548      ! 
    493549   END SUBROUTINE updatevb2b 
     550 
     551 
     552   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
     553      ! currently not used 
     554      !!--------------------------------------------- 
     555      !!           *** ROUTINE updateT *** 
     556      !!--------------------------------------------- 
     557#  include "domzgr_substitute.h90" 
     558 
     559      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     560      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     561      LOGICAL, iNTENT(in) :: before 
     562 
     563      INTEGER :: ji,jj,jk 
     564      REAL(wp) :: ztemp 
     565 
     566      IF (before) THEN 
     567         DO jk=k1,k2 
     568            DO jj=j1,j2 
     569               DO ji=i1,i2 
     570                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     571                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
     572                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
     573               END DO 
     574            END DO 
     575         END DO 
     576         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
     577         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
     578         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
     579      ELSE 
     580         DO jk=k1,k2 
     581            DO jj=j1,j2 
     582               DO ji=i1,i2 
     583                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
     584                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
     585                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
     586                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
     587                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
     588                     print *,'CORR = ',ztemp-1. 
     589                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
     590                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
     591                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
     592                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
     593                  END IF 
     594               END DO 
     595            END DO 
     596         END DO 
     597      ENDIF 
     598      ! 
     599   END SUBROUTINE update_scales 
     600 
     601# if defined key_zdftke 
     602   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
     603      !!--------------------------------------------- 
     604      !!           *** ROUTINE updateen *** 
     605      !!--------------------------------------------- 
     606      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     607      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     608      LOGICAL, INTENT(in) :: before 
     609      !!--------------------------------------------- 
     610      ! 
     611      IF (before) THEN 
     612         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
     613      ELSE 
     614         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     615      ENDIF 
     616      ! 
     617   END SUBROUTINE updateEN 
     618 
     619 
     620   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
     621      !!--------------------------------------------- 
     622      !!           *** ROUTINE updateavt *** 
     623      !!--------------------------------------------- 
     624      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     625      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     626      LOGICAL, INTENT(in) :: before 
     627      !!--------------------------------------------- 
     628      ! 
     629      IF (before) THEN 
     630         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
     631      ELSE 
     632         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     633      ENDIF 
     634      ! 
     635   END SUBROUTINE updateAVT 
     636 
     637 
     638   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
     639      !!--------------------------------------------- 
     640      !!           *** ROUTINE updateavm *** 
     641      !!--------------------------------------------- 
     642      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     643      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
     644      LOGICAL, INTENT(in) :: before 
     645      !!--------------------------------------------- 
     646      ! 
     647      IF (before) THEN 
     648         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
     649      ELSE 
     650         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
     651      ENDIF 
     652      ! 
     653   END SUBROUTINE updateAVM 
     654 
     655# endif /* key_zdftke */  
    494656 
    495657#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

    r3680 r7256  
    77   USE agrif_oce 
    88   USE agrif_top_sponge 
     9   USE par_trc 
    910   USE trc 
    1011   USE lib_mpp 
    … …  
    1415   PRIVATE 
    1516 
    16    PUBLIC Agrif_trc 
     17   PUBLIC Agrif_trc, interptrn 
    1718 
    1819#  include "domzgr_substitute.h90"   
    1920#  include "vectopt_loop_substitute.h90" 
    2021  !!---------------------------------------------------------------------- 
    21    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     22   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2223   !! $Id$ 
    2324   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2829   SUBROUTINE Agrif_trc 
    2930      !!---------------------------------------------------------------------- 
    30       !!                  ***  ROUTINE Agrif_Tra  *** 
    31       !!---------------------------------------------------------------------- 
    32       !! 
    33       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    34       REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
    35       REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
    36       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
     31      !!                  ***  ROUTINE Agrif_trc  *** 
    3732      !!---------------------------------------------------------------------- 
    3833      ! 
    3934      IF( Agrif_Root() )   RETURN 
    4035 
    41       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    42  
    4336      Agrif_SpecialValue    = 0.e0 
    4437      Agrif_UseSpecialValue = .TRUE. 
    45       ztra(:,:,:,:) = 0.e0 
    4638 
    47       CALL Agrif_Bc_variable( ztra, trn_id, procname=interptrn ) 
     39      CALL Agrif_Bc_variable( trn_id, procname=interptrn ) 
    4840      Agrif_UseSpecialValue = .FALSE. 
     41      ! 
     42   END SUBROUTINE Agrif_trc 
    4943 
    50       zrhox = Agrif_Rhox() 
     44   SUBROUTINE interptrn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
     45      !!--------------------------------------------- 
     46      !!   *** ROUTINE interptrn *** 
     47      !!--------------------------------------------- 
     48      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     49      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
     50      LOGICAL, INTENT(in) :: before 
     51      INTEGER, INTENT(in) :: nb , ndir 
     52      ! 
     53      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     54      INTEGER :: imin, imax, jmin, jmax 
     55      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
     56      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
     57      LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    5158 
    52       alpha1 = ( zrhox - 1. ) * 0.5 
    53       alpha2 = 1. - alpha1 
    54  
    55       alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    56       alpha4 = 1. - alpha3 
    57  
    58       alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    59       alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    60       alpha5 = 1. - alpha6 - alpha7 
    61       IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
    62  
    63          DO jn = 1, jptra 
    64             tra(nlci,:,:,jn) = alpha1 * ztra(nlci,:,:,jn) + alpha2 * ztra(nlci-1,:,:,jn) 
    65             DO jk = 1, jpkm1 
    66                DO jj = 1, jpj 
    67                   IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    68                      tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    69                   ELSE 
    70                      tra(nlci-1,jj,jk,jn)=(alpha4*tra(nlci,jj,jk,jn)+alpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    71                      IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    72                         tra(nlci-1,jj,jk,jn)=( alpha6*tra(nlci-2,jj,jk,jn)+alpha5*tra(nlci,jj,jk,jn)  & 
    73                            &                 + alpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     59      IF (before) THEN          
     60         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     61      ELSE 
     62         ! 
     63         western_side  = (nb == 1).AND.(ndir == 1) 
     64         eastern_side  = (nb == 1).AND.(ndir == 2) 
     65         southern_side = (nb == 2).AND.(ndir == 1) 
     66         northern_side = (nb == 2).AND.(ndir == 2) 
     67         ! 
     68         zrhox = Agrif_Rhox() 
     69         !  
     70         zalpha1 = ( zrhox - 1. ) * 0.5 
     71         zalpha2 = 1. - zalpha1 
     72         !  
     73         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     74         zalpha4 = 1. - zalpha3 
     75         !  
     76         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     77         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     78         zalpha5 = 1. - zalpha6 - zalpha7 
     79         ! 
     80         imin = i1 
     81         imax = i2 
     82         jmin = j1 
     83         jmax = j2 
     84         !  
     85         ! Remove CORNERS 
     86         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
     87         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
     88         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
     89         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
     90         ! 
     91         IF( eastern_side) THEN 
     92            DO jn = 1, jptra 
     93               tra(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
     94               DO jk = 1, jpkm1 
     95                  DO jj = jmin,jmax 
     96                     IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     97                        tra(nlci-1,jj,jk,jn) = tra(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     98                     ELSE 
     99                        tra(nlci-1,jj,jk,jn)=(zalpha4*tra(nlci,jj,jk,jn)+zalpha3*tra(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     100                        IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     101                           tra(nlci-1,jj,jk,jn)=( zalpha6*tra(nlci-2,jj,jk,jn)+zalpha5*tra(nlci,jj,jk,jn) &  
     102                                 + zalpha7*tra(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     103                        ENDIF 
    74104                     ENDIF 
    75                   ENDIF 
     105                  END DO 
     106               END DO 
     107            ENDDO 
     108         ENDIF 
     109         !  
     110         IF( northern_side ) THEN             
     111            DO jn = 1, jptra 
     112               tra(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
     113               DO jk = 1, jpkm1 
     114                  DO ji = imin,imax 
     115                     IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     116                        tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     117                     ELSE 
     118                        tra(ji,nlcj-1,jk,jn)=(zalpha4*tra(ji,nlcj,jk,jn)+zalpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     119                        IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     120                           tra(ji,nlcj-1,jk,jn)=( zalpha6*tra(ji,nlcj-2,jk,jn)+zalpha5*tra(ji,nlcj,jk,jn)  & 
     121                                 + zalpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     122                        ENDIF 
     123                     ENDIF 
     124                  END DO 
     125               END DO 
     126            ENDDO 
     127         ENDIF 
     128         ! 
     129         IF( western_side) THEN             
     130            DO jn = 1, jptra 
     131               tra(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
     132               DO jk = 1, jpkm1 
     133                  DO jj = jmin,jmax 
     134                     IF( umask(2,jj,jk) == 0.e0 ) THEN 
     135                        tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
     136                     ELSE 
     137                        tra(2,jj,jk,jn)=(zalpha4*tra(1,jj,jk,jn)+zalpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk)         
     138                        IF( un(2,jj,jk) < 0.e0 ) THEN 
     139                           tra(2,jj,jk,jn)=(zalpha6*tra(3,jj,jk,jn)+zalpha5*tra(1,jj,jk,jn)+zalpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
     140                        ENDIF 
     141                     ENDIF 
     142                  END DO 
    76143               END DO 
    77144            END DO 
    78          ENDDO 
    79       ENDIF 
    80  
    81       IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
    82  
    83          DO jn = 1, jptra 
    84             tra(:,nlcj,:,jn) = alpha1 * ztra(:,nlcj,:,jn) + alpha2 * ztra(:,nlcj-1,:,jn) 
    85             DO jk = 1, jpkm1 
    86                DO ji = 1, jpi 
    87                   IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    88                      tra(ji,nlcj-1,jk,jn) = tra(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    89                   ELSE 
    90                      tra(ji,nlcj-1,jk,jn)=(alpha4*tra(ji,nlcj,jk,jn)+alpha3*tra(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk) 
    91                      IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    92                         tra(ji,nlcj-1,jk,jn)=( alpha6*tra(ji,nlcj-2,jk,jn)+alpha5*tra(ji,nlcj,jk,jn)  & 
    93                            &                 + alpha7*tra(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     145         ENDIF 
     146         ! 
     147         IF( southern_side ) THEN            
     148            DO jn = 1, jptra 
     149               tra(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
     150               DO jk=1,jpk       
     151                  DO ji=imin,imax 
     152                     IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     153                        tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
     154                     ELSE 
     155                        tra(ji,2,jk,jn)=(zalpha4*tra(ji,1,jk,jn)+zalpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
     156                        IF( vn(ji,2,jk) < 0.e0 ) THEN 
     157                           tra(ji,2,jk,jn)=(zalpha6*tra(ji,3,jk,jn)+zalpha5*tra(ji,1,jk,jn)+zalpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
     158                        ENDIF 
    94159                     ENDIF 
    95                   ENDIF 
     160                  END DO 
    96161               END DO 
    97             END DO 
    98          ENDDO 
    99       ENDIF 
    100       IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
    101          DO jn = 1, jptra 
    102             tra(1,:,:,jn) = alpha1 * ztra(1,:,:,jn) + alpha2 * ztra(2,:,:,jn) 
    103             DO jk = 1, jpkm1 
    104                DO jj = 1, jpj 
    105                   IF( umask(2,jj,jk) == 0.e0 ) THEN 
    106                      tra(2,jj,jk,jn) = tra(1,jj,jk,jn) * tmask(2,jj,jk) 
    107                   ELSE 
    108                      tra(2,jj,jk,jn)=(alpha4*tra(1,jj,jk,jn)+alpha3*tra(3,jj,jk,jn))*tmask(2,jj,jk) 
    109                      IF( un(2,jj,jk) < 0.e0 ) THEN 
    110                         tra(2,jj,jk,jn)=(alpha6*tra(3,jj,jk,jn)+alpha5*tra(1,jj,jk,jn)+alpha7*tra(4,jj,jk,jn))*tmask(2,jj,jk) 
    111                      ENDIF 
    112                   ENDIF 
    113                END DO 
    114             END DO 
    115          END DO 
    116       ENDIF 
    117  
    118       IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
    119          DO jn = 1, jptra 
    120             tra(:,1,:,jn) = alpha1 * ztra(:,1,:,jn) + alpha2 * ztra(:,2,:,jn) 
    121             DO jk=1,jpk 
    122                DO ji=1,jpi 
    123                   IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    124                      tra(ji,2,jk,jn)=tra(ji,1,jk,jn) * tmask(ji,2,jk) 
    125                   ELSE 
    126                      tra(ji,2,jk,jn)=(alpha4*tra(ji,1,jk,jn)+alpha3*tra(ji,3,jk,jn))*tmask(ji,2,jk) 
    127                      IF( vn(ji,2,jk) < 0.e0 ) THEN 
    128                         tra(ji,2,jk,jn)=(alpha6*tra(ji,3,jk,jn)+alpha5*tra(ji,1,jk,jn)+alpha7*tra(ji,4,jk,jn))*tmask(ji,2,jk) 
    129                      ENDIF 
    130                   ENDIF 
    131                END DO 
    132             END DO 
    133          ENDDO 
     162            ENDDO 
     163         ENDIF 
     164         ! 
     165         ! Treatment of corners 
     166         !  
     167         ! East south 
     168         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     169            tra(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
     170         ENDIF 
     171         ! East north 
     172         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     173            tra(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
     174         ENDIF 
     175         ! West south 
     176         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
     177            tra(2,2,:,:) = ptab(2,2,:,:) 
     178         ENDIF 
     179         ! West north 
     180         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
     181            tra(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
     182         ENDIF 
     183         ! 
    134184      ENDIF 
    135185      ! 
    136       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    137       ! 
    138  
    139    END SUBROUTINE Agrif_trc 
     186   END SUBROUTINE interptrn 
    140187 
    141188#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r3680 r7256  
    11#define SPONGE_TOP 
    22 
    3 Module agrif_top_sponge 
     3MODULE agrif_top_sponge 
    44#if defined key_agrif && defined key_top 
    55   USE par_oce 
     6   USE par_trc 
    67   USE oce 
    78   USE dom_oce 
    … …  
    1617   PRIVATE 
    1718 
    18    PUBLIC Agrif_Sponge_Trc, interptrn 
     19   PUBLIC Agrif_Sponge_trc, interptrn_sponge 
    1920 
    20   !! * Substitutions 
     21   !! * Substitutions 
    2122#  include "domzgr_substitute.h90" 
    2223   !!---------------------------------------------------------------------- 
    23    !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     24   !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    2425   !! $Id$ 
    2526   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2627   !!---------------------------------------------------------------------- 
    2728 
    28    CONTAINS 
     29CONTAINS 
    2930 
    30    SUBROUTINE Agrif_Sponge_Trc 
     31   SUBROUTINE Agrif_Sponge_trc 
    3132      !!--------------------------------------------- 
    3233      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3334      !!--------------------------------------------- 
    3435      !!  
    35       INTEGER :: ji,jj,jk,jn 
    3636      REAL(wp) :: timecoeff 
    37       REAL(wp) :: ztra, zabe1, zabe2, zbtr 
    38       REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv 
    39       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr 
    40       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff 
    4137 
    4238#if defined SPONGE_TOP 
    43       CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
    44       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
    45  
    4639      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    47  
     40      CALL Agrif_sponge 
    4841      Agrif_SpecialValue=0. 
    4942      Agrif_UseSpecialValue = .TRUE. 
    50       ztabr = 0.e0 
    51       CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
     43      tabspongedone_trn = .FALSE. 
     44      CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 
    5245      Agrif_UseSpecialValue = .FALSE. 
    53  
    54       trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:) 
    55  
    56       CALL Agrif_sponge 
    57  
    58       DO jn = 1, jptra 
    59          DO jk = 1, jpkm1 
    60             ! 
    61             DO jj = 1, jpjm1 
    62                DO ji = 1, jpim1 
    63                   zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
    64                   zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
    65                   ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    66                   ztrv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    67                ENDDO 
    68             ENDDO 
    69  
    70             DO jj = 2,jpjm1 
    71                DO ji = 2,jpim1 
    72                   zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
    73                   ! horizontal diffusive trends 
    74                   ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1)  ) 
    75                   ! add it to the general tracer trends 
    76                   tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
    77                END DO 
    78             END DO 
    79             ! 
    80          ENDDO 
    81       ENDDO 
    82   
    83       CALL wrk_dealloc( jpi, jpj, ztru, ztrv ) 
    84       CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr ) 
    8546 
    8647#endif 
    … …  
    8849   END SUBROUTINE Agrif_Sponge_Trc 
    8950 
    90    SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
     51   SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    9152      !!--------------------------------------------- 
    92       !!   *** ROUTINE interptn *** 
     53      !!   *** ROUTINE interptrn_sponge *** 
    9354      !!--------------------------------------------- 
    9455      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    9556      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     57      LOGICAL, INTENT(in) :: before 
     58 
     59 
     60      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     61 
     62      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
     63      REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 
     64      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 
    9665      ! 
    97       tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     66      IF (before) THEN 
     67         tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
     68      ELSE       
    9869 
    99    END SUBROUTINE interptrn 
     70         trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
     71         DO jn = 1, jptra 
     72            DO jk = 1, jpkm1 
     73 
     74               DO jj = j1,j2-1 
     75                  DO ji = i1,i2-1 
     76                     zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
     77                     zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
     78                     ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     79                     ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     80                  ENDDO 
     81               ENDDO 
     82 
     83               DO jj = j1+1,j2-1 
     84                  DO ji = i1+1,i2-1 
     85 
     86                     IF (.NOT. tabspongedone_trn(ji,jj)) THEN  
     87                        zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,jk) 
     88                        ! horizontal diffusive trends 
     89                        ztra = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
     90                        ! add it to the general tracer trends 
     91                        tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     92                     ENDIF 
     93 
     94                  ENDDO 
     95               ENDDO 
     96 
     97            ENDDO 
     98         ENDDO 
     99 
     100         tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
     101      ENDIF 
     102      !                  
     103   END SUBROUTINE interptrn_sponge 
    100104 
    101105#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r4491 r7256  
    11#define TWO_WAY 
     2#undef DECAL_FEEDBACK 
    23 
    34MODULE agrif_top_update 
    … …  
    89   USE dom_oce 
    910   USE agrif_oce 
     11   USE par_trc 
    1012   USE trc 
    1113   USE wrk_nemo   
    … …  
    2426   !!---------------------------------------------------------------------- 
    2527 
    26    CONTAINS 
     28CONTAINS 
    2729 
    2830   SUBROUTINE Agrif_Update_Trc( kt ) 
    … …  
    3032      !!   *** ROUTINE Agrif_Update_Trc *** 
    3133      !!--------------------------------------------- 
    32       !! 
    3334      INTEGER, INTENT(in) :: kt 
    34       REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
    35  
    36    
    37       IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    38  
    39 #if defined TWO_WAY 
    40       CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
    41  
     35      !!--------------------------------------------- 
     36      !  
     37      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     38#if defined TWO_WAY    
    4239      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4340      Agrif_SpecialValueFineGrid = 0. 
    44   
    45      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
    46          CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 
     41      !  
     42      IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
     43# if ! defined DECAL_FEEDBACK 
     44         CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 
     45# else 
     46         CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 
     47# endif 
    4748      ELSE 
    48          CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 
     49# if ! defined DECAL_FEEDBACK 
     50         CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 
     51# else 
     52         CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 
     53# endif 
    4954      ENDIF 
    50  
     55      ! 
    5156      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5257      nbcline_trc = nbcline_trc + 1 
    53  
    54       CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5558#endif 
    56  
     59      ! 
    5760   END SUBROUTINE Agrif_Update_Trc 
    5861 
    59    SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     62   SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    6063      !!--------------------------------------------- 
    61       !!   *** ROUTINE UpdateTrc *** 
     64      !!           *** ROUTINE updateT *** 
    6265      !!--------------------------------------------- 
     66#  include "domzgr_substitute.h90" 
    6367      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    64       REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
     68      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    6569      LOGICAL, INTENT(in) :: before 
    66     
     70      !! 
    6771      INTEGER :: ji,jj,jk,jn 
    68  
    69          IF( before ) THEN 
    70             DO jn = n1, n2 
    71                DO jk = k1, k2 
    72                   DO jj = j1, j2 
    73                      DO ji = i1, i2 
    74                         tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    75                      ENDDO 
    76                   ENDDO 
    77                ENDDO 
    78             ENDDO 
    79          ELSE 
    80             IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     72      !!--------------------------------------------- 
     73      ! 
     74      IF (before) THEN 
     75         DO jn = n1,n2 
     76            DO jk=k1,k2 
     77               DO jj=j1,j2 
     78                  DO ji=i1,i2 
     79                     ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     80                  END DO 
     81               END DO 
     82            END DO 
     83         END DO 
     84      ELSE 
     85         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    8186            ! Add asselin part 
    82                DO jn = n1, n2 
    83                   DO jk = k1, k2 
    84                      DO jj = j1, j2 
    85                         DO ji = i1, i2 
    86                            IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    87                               trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
    88                                  & + atfp * ( tabres(ji,jj,jk,jn) & 
    89                                                - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    90                            ENDIF 
    91                         ENDDO 
    92                      ENDDO 
    93                   ENDDO 
    94                ENDDO 
    95             ENDIF 
    96  
    97             DO jn = n1, n2 
    98                DO jk = k1, k2 
    99                   DO jj = j1, j2 
    100                      DO ji = i1, i2 
    101                         IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    102                            trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     87            DO jn = n1,n2 
     88               DO jk=k1,k2 
     89                  DO jj=j1,j2 
     90                     DO ji=i1,i2 
     91                        IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 
     92                           trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
     93                                 & + atfp * ( ptab(ji,jj,jk,jn) & 
     94                                 &             - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    10395                        ENDIF 
    10496                     ENDDO 
    … …  
    10799            ENDDO 
    108100         ENDIF 
    109  
     101         DO jn = n1,n2 
     102            DO jk=k1,k2 
     103               DO jj=j1,j2 
     104                  DO ji=i1,i2 
     105                     IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN  
     106                        trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 
     107                     END IF 
     108                  END DO 
     109               END DO 
     110            END DO 
     111         END DO 
     112      ENDIF 
     113      !  
    110114   END SUBROUTINE updateTRC 
    111115 
    … …  
    119123   END SUBROUTINE agrif_top_update_empty 
    120124#endif 
    121 END Module agrif_top_update 
     125END MODULE agrif_top_update 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r4624 r7256  
    1717   USE par_oce 
    1818   USE dom_oce 
    19    USE Agrif_Util 
    2019   USE nemogcm 
    2120   ! 
    … …  
    3130      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    3231      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    33       jpk     = jpkdta  
     32! JC: change to allow for different vertical levels 
     33!     jpk is already set 
     34!     keep it jpk possibly different from jpkdta which  
     35!     hold parent grid vertical levels number (set earlier) 
     36!      jpk     = jpkdta  
    3437      jpim1   = jpi-1  
    3538      jpjm1   = jpj-1  
    … …  
    6467   ! 0. Initializations 
    6568   !------------------- 
    66    IF( cp_cfg == 'orca' ) then 
     69   IF( cp_cfg == 'orca' ) THEN 
    6770      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    68   &                      .OR. jp_cfg == 4 ) THEN 
     71            &                      .OR. jp_cfg == 4 ) THEN 
    6972         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    7073         cp_cfg = "default" 
    … …  
    120123SUBROUTINE agrif_declare_var_dom 
    121124   !!---------------------------------------------------------------------- 
    122    !!                 *** ROUTINE agrif_declarE_var *** 
     125   !!                 *** ROUTINE agrif_declare_var *** 
    123126   !! 
    124127   !! ** Purpose :: Declaration of variables to be interpolated 
    125128   !!---------------------------------------------------------------------- 
    126129   USE agrif_util 
    127    USE par_oce       !   ONLY : jpts 
     130   USE par_oce        
    128131   USE oce 
    129132   IMPLICIT NONE 
    … …  
    132135   ! 1. Declaration of the type of variable which have to be interpolated 
    133136   !--------------------------------------------------------------------- 
    134    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
    135    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
    136  
     137   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
     138   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
    137139 
    138140   ! 2. Type of interpolation 
    139141   !------------------------- 
    140    Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    141    Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     142   CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     143   CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    142144 
    143145   ! 3. Location of interpolation 
    144146   !----------------------------- 
    145    Call Agrif_Set_bc(e1u_id,(/0,0/)) 
    146    Call Agrif_Set_bc(e2v_id,(/0,0/)) 
     147   CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
     148   CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
    147149 
    148150   ! 5. Update type 
    149151   !---------------  
    150    Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    151    Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    152  
     152   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     153   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     154 
     155! High order updates 
     156!   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average,            update2=Agrif_Update_Full_Weighting) 
     157!   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting,     update2=Agrif_Update_Average) 
     158    ! 
    153159END SUBROUTINE agrif_declare_var_dom 
    154160 
    … …  
    167173   USE nemogcm 
    168174   USE sol_oce 
     175   USE lib_mpp 
    169176   USE in_out_manager 
    170177   USE agrif_opa_update 
    … …  
    174181   IMPLICIT NONE 
    175182   ! 
    176    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
    177    REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
    178    REAL(wp), DIMENSION(:,:    ), ALLOCATABLE :: tab2d 
    179183   LOGICAL :: check_namelist 
    180    !!---------------------------------------------------------------------- 
    181  
    182    ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
    183    ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
    184    ALLOCATE( tab2d(jpi, jpj)                ) 
    185  
     184   CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 
     185   !!---------------------------------------------------------------------- 
    186186 
    187187   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    193193   Agrif_SpecialValue=0. 
    194194   Agrif_UseSpecialValue = .TRUE. 
    195    Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
    196    Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
    197  
    198    Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
    199    Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
    200    Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
    201    Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
    202  
    203    Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 
    204    Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 
    205    Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 
    206    Agrif_UseSpecialValue = .FALSE. 
     195   CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
     196   CALL Agrif_Sponge 
     197   tabspongedone_tsn = .FALSE. 
     198   CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
     199   ! reset tsa to zero 
     200   tsa(:,:,:,:) = 0. 
     201 
     202   Agrif_UseSpecialValue = ln_spc_dyn 
     203   CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
     204   CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
     205   tabspongedone_u = .FALSE. 
     206   tabspongedone_v = .FALSE. 
     207   CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
     208   tabspongedone_u = .FALSE. 
     209   tabspongedone_v = .FALSE. 
     210   CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
     211 
     212#if defined key_dynspg_ts 
     213   Agrif_UseSpecialValue = .TRUE. 
     214   CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
     215 
     216   Agrif_UseSpecialValue = ln_spc_dyn 
     217   CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
     218   CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
     219   CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
     220   CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
     221   ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 
     222   ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0  
     223   ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0  
     224   ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 
     225#endif 
     226 
     227   Agrif_UseSpecialValue = .FALSE.  
     228   ! reset velocities to zero 
     229   ua(:,:,:) = 0. 
     230   va(:,:,:) = 0. 
    207231 
    208232   ! 3. Some controls 
    209233   !----------------- 
    210    check_namelist = .true. 
    211  
    212    IF( check_namelist ) THEN 
     234   check_namelist = .TRUE. 
     235 
     236   IF( check_namelist ) THEN  
    213237 
    214238      ! Check time steps            
    215       IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
    216          WRITE(*,*) 'incompatible time step between grids' 
    217          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    218          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    219          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    220          STOP 
     239      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     240         WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
     241         WRITE(cl_check2,*)  NINT(rdt) 
     242         WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
     243         CALL ctl_warn( 'incompatible time step between grids',   & 
     244               &               'parent grid value : '//cl_check1    ,   &  
     245               &               'child  grid value : '//cl_check2    ,   &  
     246               &               'value on child grid will be changed to : '//cl_check3 ) 
     247         rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
    221248      ENDIF 
    222249 
    223250      ! Check run length 
    224251      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    225            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    226          WRITE(*,*) 'incompatible run length between grids' 
    227          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    228               Agrif_Parent(nit000)+1),' time step' 
    229          WRITE(*,*) 'child  grid value : ', & 
    230               (nitend-nit000+1),' time step' 
    231          WRITE(*,*) 'value on child grid should be : ', & 
    232               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    233               Agrif_Parent(nit000)+1) 
    234          STOP 
     252            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     253         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     254         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     255         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     256               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     257               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     258         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     259         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    235260      ENDIF 
    236261 
    … …  
    238263      IF( ln_zps ) THEN 
    239264         ! check parameters for partial steps  
    240          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     265         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    241266            WRITE(*,*) 'incompatible e3zps_min between grids' 
    242267            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    253278         ENDIF 
    254279      ENDIF 
     280      ! check if masks and bathymetries match 
     281      IF(ln_chk_bathy) THEN 
     282         ! 
     283         IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
     284         ! 
     285         kindic_agr = 0 
     286         ! check if umask agree with parent along western and eastern boundaries: 
     287         CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
     288         ! check if vmask agree with parent along northern and southern boundaries: 
     289         CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
     290    ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
     291         CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
     292         ! 
     293         IF (lk_mpp) CALL mpp_sum( kindic_agr ) 
     294         IF( kindic_agr /= 0 ) THEN                    
     295            CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
     296         ELSE 
     297            IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
     298         END IF 
     299      ENDIF 
     300      ! 
    255301   ENDIF 
    256  
    257    CALL Agrif_Update_tra(0) 
    258    CALL Agrif_Update_dyn(0) 
    259  
     302   !  
     303   ! Do update at initialisation because not done before writing restarts 
     304   ! This would indeed change boundary conditions values at initial time 
     305   ! hence produce restartability issues. 
     306   ! Note that update below is recursive (with lk_agrif_doupd=T): 
     307   !  
     308! JC: I am not sure if Agrif_MaxLevel() is the "relative" 
     309!     or the absolute maximum nesting level...TBC                         
     310   IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN  
     311      ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 
     312      CALL Agrif_Update_tra() 
     313      CALL Agrif_Update_dyn() 
     314   ENDIF 
     315   ! 
     316# if defined key_zdftke 
     317!   CALL Agrif_Update_tke(0) 
     318# endif 
     319   ! 
     320   Agrif_UseSpecialValueInUpdate = .FALSE. 
    260321   nbcline = 0 
    261    ! 
    262    DEALLOCATE(tabtstemp) 
    263    DEALLOCATE(tabuvtemp) 
    264    DEALLOCATE(tab2d) 
     322   lk_agrif_doupd = .FALSE. 
    265323   ! 
    266324END SUBROUTINE Agrif_InitValues_cont 
    … …  
    276334   USE par_oce       !   ONLY : jpts 
    277335   USE oce 
     336   USE agrif_oce 
    278337   IMPLICIT NONE 
    279338   !!---------------------------------------------------------------------- 
    … …  
    281340   ! 1. Declaration of the type of variable which have to be interpolated 
    282341   !--------------------------------------------------------------------- 
    283    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
    284    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
    285    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
    286  
    287    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
    288    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
    289    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
    290    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
    291  
    292    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 
    293    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 
    294    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
    295    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
    296    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 
    297    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 
     342   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
     343   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
     344 
     345   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
     346   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
     347   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
     348   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
     349   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
     350   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
     351 
     352   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
     353   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
     354   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
     355 
     356   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
     357 
     358   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
     359   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
     360   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
     361   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
     362   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
     363   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
     364 
     365   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
     366 
     367# if defined key_zdftke 
     368   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
     369   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
     370   CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
     371# endif 
    298372 
    299373   ! 2. Type of interpolation 
    300374   !------------------------- 
    301375   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    302    CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
    303  
    304    Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    305    Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    306  
    307    Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    308    Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     376 
     377   CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     378   CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     379 
     380   CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
    309381 
    310382   CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    311    Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    312    Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    313    Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    314    Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     383   CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     384   CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     385   CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     386   CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     387 
     388 
     389   CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     390   CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     391 
     392   CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
     393   CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
     394   CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
     395 
     396# if defined key_zdftke 
     397   CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
     398# endif 
     399 
    315400 
    316401   ! 3. Location of interpolation 
    317402   !----------------------------- 
    318    Call Agrif_Set_bc(un_id,(/0,1/)) 
    319    Call Agrif_Set_bc(vn_id,(/0,1/)) 
    320  
    321    Call Agrif_Set_bc(sshn_id,(/0,1/)) 
    322    Call Agrif_Set_bc(unb_id,(/0,1/)) 
    323    Call Agrif_Set_bc(vnb_id,(/0,1/)) 
    324    Call Agrif_Set_bc(ub2b_id,(/0,1/)) 
    325    Call Agrif_Set_bc(vb2b_id,(/0,1/)) 
    326  
    327    Call Agrif_Set_bc(tsn_id,(/0,1/)) 
    328    Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
    329  
    330    Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
    331    Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
     403   CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
     404   CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
     405   CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
     406 
     407!   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     408!   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     409!   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
     410   CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     411   CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     412   CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     413 
     414   CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
     415   CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
     416   CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
     417   CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
     418   CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
     419 
     420   CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
     421   CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
     422   CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
     423 
     424# if defined key_zdftke 
     425   CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
     426# endif 
    332427 
    333428   ! 5. Update type 
    334429   !---------------  
    335    Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    336    Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
    337  
    338    Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    339    Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
    340  
    341    Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    342    Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    343  
    344    Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    345    Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    346  
     430   CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     431 
     432   CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
     433 
     434   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     435   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     436 
     437   CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     438 
     439   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     440   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     441 
     442# if defined key_zdftke 
     443   CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
     444   CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
     445   CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
     446# endif 
     447 
     448! High order updates 
     449!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     450!   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     451!   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     452! 
     453!   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
     454!   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
     455!   CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
     456  
     457   ! 
    347458END SUBROUTINE agrif_declare_var 
    348459# endif 
    … …  
    365476   IMPLICIT NONE 
    366477   ! 
    367    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
    368    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
    369    !!---------------------------------------------------------------------- 
    370  
    371    ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
     478   !!---------------------------------------------------------------------- 
    372479 
    373480   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    401508   CALL Agrif_Update_lim2(0) 
    402509   ! 
    403    DEALLOCATE( zvel, zadv ) 
    404    ! 
    405510END SUBROUTINE Agrif_InitValues_cont_lim2 
    406511 
    … …  
    431536   !------------------------- 
    432537   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    433    Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    434    Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     538   CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     539   CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    435540 
    436541   ! 3. Location of interpolation 
    437542   !----------------------------- 
    438    Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    439    Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
    440    Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
     543   CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     544   CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
     545   CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
    441546 
    442547   ! 5. Update type 
    443548   !--------------- 
    444    Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    445    Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    446    Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    447  
     549   CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     550   CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     551   CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     552   !  
    448553END SUBROUTINE agrif_declare_var_lim2 
    449554#  endif 
    … …  
    462567   USE nemogcm 
    463568   USE par_trc 
     569   USE lib_mpp 
    464570   USE trc 
    465571   USE in_out_manager 
     572   USE agrif_opa_sponge 
    466573   USE agrif_top_update 
    467574   USE agrif_top_interp 
    … …  
    470577   IMPLICIT NONE 
    471578   ! 
    472    REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
     579   CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
    473580   LOGICAL :: check_namelist 
    474581   !!---------------------------------------------------------------------- 
    475  
    476    ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    477582 
    478583 
    … …  
    485590   Agrif_SpecialValue=0. 
    486591   Agrif_UseSpecialValue = .TRUE. 
    487    Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
    488    Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
     592   CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
    489593   Agrif_UseSpecialValue = .FALSE. 
     594   CALL Agrif_Sponge 
     595   tabspongedone_trn = .FALSE. 
     596   CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
     597   ! reset tsa to zero 
     598   tra(:,:,:,:) = 0. 
     599 
    490600 
    491601   ! 3. Some controls 
    492602   !----------------- 
    493    check_namelist = .true. 
     603   check_namelist = .TRUE. 
    494604 
    495605   IF( check_namelist ) THEN 
    496 #  if defined offline      
     606# if defined key_offline 
    497607      ! Check time steps 
    498       IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
    499          WRITE(*,*) 'incompatible time step between grids' 
    500          WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
    501          WRITE(*,*) 'child  grid value : ',nint(rdt) 
    502          WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
    503          STOP 
     608      IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
     609         WRITE(cl_check1,*)  Agrif_Parent(rdt) 
     610         WRITE(cl_check2,*)  rdt 
     611         WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
     612         CALL ctl_warn( 'incompatible time step between grids',   & 
     613               &               'parent grid value : '//cl_check1    ,   &  
     614               &               'child  grid value : '//cl_check2    ,   &  
     615               &               'value on child grid will be changed to  & 
     616               &               :'//cl_check3  ) 
     617         rdt=rdt*Agrif_Rhot() 
    504618      ENDIF 
    505619 
    506620      ! Check run length 
    507621      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    508            Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
    509          WRITE(*,*) 'incompatible run length between grids' 
    510          WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
    511               Agrif_Parent(nit000)+1),' time step' 
    512          WRITE(*,*) 'child  grid value : ', & 
    513               (nitend-nit000+1),' time step' 
    514          WRITE(*,*) 'value on child grid should be : ', & 
    515               Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    516               Agrif_Parent(nit000)+1) 
    517          STOP 
     622            Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
     623         WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     624         WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
     625         CALL ctl_warn( 'incompatible run length between grids'               ,   & 
     626               &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
     627               &              ' nitend on fine grid will be change to : '//cl_check2    ) 
     628         nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
     629         nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
    518630      ENDIF 
    519631 
    … …  
    521633      IF( ln_zps ) THEN 
    522634         ! check parameters for partial steps  
    523          IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
     635         IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
    524636            WRITE(*,*) 'incompatible e3zps_min between grids' 
    525637            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    528640            STOP 
    529641         ENDIF 
    530          IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
     642         IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
    531643            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    532644            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    … …  
    538650#  endif          
    539651      ! Check passive tracer cell 
    540       IF( nn_dttrc .ne. 1 ) THEN 
     652      IF( nn_dttrc .NE. 1 ) THEN 
    541653         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    542654      ENDIF 
    543655   ENDIF 
    544656 
    545 !ch   CALL Agrif_Update_trc(0) 
     657   CALL Agrif_Update_trc(0) 
     658   ! 
     659   Agrif_UseSpecialValueInUpdate = .FALSE. 
    546660   nbcline_trc = 0 
    547    ! 
    548    DEALLOCATE(tabtrtemp) 
    549661   ! 
    550662END SUBROUTINE Agrif_InitValues_cont_top 
    … …  
    558670   !!---------------------------------------------------------------------- 
    559671   USE agrif_util 
     672   USE agrif_oce 
    560673   USE dom_oce 
    561674   USE trc 
    … …  
    565678   ! 1. Declaration of the type of variable which have to be interpolated 
    566679   !--------------------------------------------------------------------- 
    567    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
    568    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
    569    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
     680   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
     681   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
    570682 
    571683   ! 2. Type of interpolation 
    572684   !------------------------- 
    573685   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    574    CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
     686   CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
    575687 
    576688   ! 3. Location of interpolation 
    577689   !----------------------------- 
    578    Call Agrif_Set_bc(trn_id,(/0,1/)) 
    579    Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
     690   CALL Agrif_Set_bc(trn_id,(/0,1/)) 
     691!   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
     692   CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    580693 
    581694   ! 5. Update type 
    582695   !---------------  
    583    Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    584    Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
    585  
    586  
     696   CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     697 
     698!   Higher order update 
     699!   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
     700 
     701   ! 
    587702END SUBROUTINE agrif_declare_var_top 
    588703# endif 
    … …  
    592707   !!   *** ROUTINE Agrif_detect *** 
    593708   !!---------------------------------------------------------------------- 
    594    USE Agrif_Types 
    595709   ! 
    596710   INTEGER, DIMENSION(2) :: ksizex 
    … …  
    614728   ! 
    615729   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    616    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
    617    !!---------------------------------------------------------------------- 
    618    ! 
    619       REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    620       READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    621 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    622  
    623       REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    624       READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    625 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    626       IF(lwm) WRITE ( numond, namagrif ) 
     730   INTEGER  ::   iminspon 
     731   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
     732   !!-------------------------------------------------------------------------------------- 
     733   ! 
     734   REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     735   READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     736901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     737 
     738   REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     739   READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     740902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     741   IF(lwm) WRITE ( numond, namagrif ) 
    627742   ! 
    628743   IF(lwp) THEN                    ! control print 
    … …  
    635750      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    636751      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
     752      WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    637753      WRITE(numout,*)  
    638754   ENDIF 
    … …  
    643759   visc_dyn      = rn_sponge_dyn 
    644760   ! 
    645    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
     761   ! Check sponge length: 
     762   iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 
     763   IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 
     764   IF (nn_sponge_len > iminspon)  CALL ctl_stop('agrif sponge length is too large') 
     765   ! 
     766   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
    646767# if defined key_lim2 
    647768   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    … …  
    664785   SELECT CASE( i ) 
    665786   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    666    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
    667    CASE(3)   ;   indglob = indloc 
    668    CASE(4)   ;   indglob = indloc 
     787   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
     788   CASE DEFAULT 
     789      indglob = indloc 
    669790   END SELECT 
    670791   ! 
    671792END SUBROUTINE Agrif_InvLoc 
     793 
     794SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
     795   !!---------------------------------------------------------------------- 
     796   !!                 *** ROUTINE Agrif_get_proc_info *** 
     797   !!---------------------------------------------------------------------- 
     798   USE par_oce 
     799   IMPLICIT NONE 
     800   ! 
     801   INTEGER, INTENT(out) :: imin, imax 
     802   INTEGER, INTENT(out) :: jmin, jmax 
     803   !!---------------------------------------------------------------------- 
     804   ! 
     805   imin = nimppt(Agrif_Procrank+1)  ! ????? 
     806   jmin = njmppt(Agrif_Procrank+1)  ! ????? 
     807   imax = imin + jpi - 1 
     808   jmax = jmin + jpj - 1 
     809   !  
     810END SUBROUTINE Agrif_get_proc_info 
     811 
     812SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
     813   !!---------------------------------------------------------------------- 
     814   !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
     815   !!---------------------------------------------------------------------- 
     816   USE par_oce 
     817   IMPLICIT NONE 
     818   ! 
     819   INTEGER,  INTENT(in)  :: imin, imax 
     820   INTEGER,  INTENT(in)  :: jmin, jmax 
     821   INTEGER,  INTENT(in)  :: nbprocs 
     822   REAL(wp), INTENT(out) :: grid_cost 
     823   !!---------------------------------------------------------------------- 
     824   ! 
     825   grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
     826   ! 
     827END SUBROUTINE Agrif_estimate_parallel_cost 
    672828 
    673829# endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

    r5602 r7256  
    431431         CALL ctl_stop( 'dta_dyn: unable to allocate sf structure' )   ;   RETURN 
    432432      ENDIF 
     433      !                                         ! fill sf with slf_i and control print 
     434      CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 
    433435      ! Open file for each variable to get his number of dimension 
    434436      DO ifpr = 1, jfld 
    435          CALL iom_open( TRIM( cn_dir )//TRIM( slf_d(ifpr)%clname ), inum ) 
    436          idv   = iom_varid( inum , slf_d(ifpr)%clvar )  ! id of the variable sdjf%clvar 
    437          idimv = iom_file ( inum )%ndims(idv)             ! number of dimension for variable sdjf%clvar 
    438          IF( inum /= 0 )   CALL iom_close( inum )       ! close file if already open 
     437         CALL fld_clopn( sf_dyn(ifpr), nyear, nmonth, nday ) 
     438         idv   = iom_varid( sf_dyn(ifpr)%num , slf_d(ifpr)%clvar )        ! id of the variable sdjf%clvar 
     439         idimv = iom_file ( sf_dyn(ifpr)%num )%ndims(idv)                 ! number of dimension for variable sdjf%clvar 
     440         IF( sf_dyn(ifpr)%num /= 0 )   CALL iom_close( sf_dyn(ifpr)%num ) ! close file if already open 
     441         ierr1=0 
    439442         IF( idimv == 3 ) THEN    ! 2D variable 
    440443                                      ALLOCATE( sf_dyn(ifpr)%fnow(jpi,jpj,1)    , STAT=ierr0 ) 
    … …  
    448451         ENDIF 
    449452      END DO 
    450       !                                         ! fill sf with slf_i and control print 
    451       CALL fld_fill( sf_dyn, slf_d, cn_dir, 'dta_dyn_init', 'Data in file', 'namdta_dyn' ) 
    452453      ! 
    453454      IF( lk_ldfslp .AND. .NOT.lk_c1d ) THEN                  ! slopes  

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

    r5602 r7256  
    658658 
    659659      DO jk = 1, jpkm1 
    660          fzptnz(:,:,jk) = eos_fzp( tsn(:,:,jk,jp_sal), fsdept(:,:,jk) ) 
     660        CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), fsdept(:,:,jk) ) 
    661661      END DO 
    662662 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

    r5602 r7256  
    430430      CHARACTER(len=100)                     ::   cn_dir        ! Root directory for location of data files 
    431431      CHARACTER(len=100), DIMENSION(nb_bdy)  ::   cn_dir_array  ! Root directory for location of data files 
     432      CHARACTER(len = 256)::   clname                           ! temporary file name 
    432433      LOGICAL                                ::   ln_full_vel   ! =T => full velocities in 3D boundary data 
    433434                                                                ! =F => baroclinic velocities in 3D boundary data 
    … …  
    669670            ! sea ice 
    670671            IF( nn_ice_lim_dta(ib_bdy) .eq. 1 ) THEN 
    671  
    672                ! Test for types of ice input (lim2 or lim3)  
    673                CALL iom_open ( bn_a_i%clname, inum ) 
    674                id1 = iom_varid ( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     672               ! Test for types of ice input (lim2 or lim3) 
     673               ! Build file name to find dimensions  
     674               clname=TRIM(bn_a_i%clname) 
     675               IF( .NOT. bn_a_i%ln_clim ) THEN    
     676                                                  WRITE(clname, '(a,"_y",i4.4)' ) TRIM( bn_a_i%clname ), nyear    ! add year 
     677                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname        ), nmonth   ! add month 
     678               ELSE 
     679                  IF( bn_a_i%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( bn_a_i%clname ), nmonth   ! add month 
     680               ENDIF 
     681               IF( bn_a_i%cltype == 'daily' .OR. bn_a_i%cltype(1:4) == 'week' ) & 
     682               &                                  WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname        ), nday     ! add day 
     683               ! 
     684               CALL iom_open  ( clname, inum ) 
     685               id1 = iom_varid( inum, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
    675686               CALL iom_close ( inum ) 
    676                !CALL fld_clopn ( bn_a_i, nyear, nmonth, nday, ldstop=.TRUE. ) 
    677                !CALL iom_open ( bn_a_i%clname, inum ) 
    678                !id1 = iom_varid ( bn_a_i%num, bn_a_i%clvar, kdimsz=zdimsz, kndims=zndims, ldstop = .FALSE. ) 
     687 
    679688                IF ( zndims == 4 ) THEN 
    680689                 ll_bdylim3 = .TRUE.   ! lim3 input 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

    r5602 r7256  
    4949      !!---------------------------------------------------------------------- 
    5050      INTEGER,                      INTENT(in) ::   kt   ! Main time step counter 
    51       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
    52       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pub2d, pvb2d 
    53       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: phur, phvr 
    54       REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) :: pssh 
     51      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
     52      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pub2d, pvb2d 
     53      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: phur, phvr 
     54      REAL(wp), DIMENSION(:,:), INTENT(in   ) :: pssh 
    5555      !! 
    5656      INTEGER                                  ::   ib_bdy ! Loop counter 
    … …  
    9292      TYPE(OBC_DATA),  INTENT(in) ::   dta  ! OBC external data 
    9393      INTEGER,         INTENT(in) ::   ib_bdy  ! BDY set index 
    94       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d  
     94      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d  
    9595      !! 
    9696      INTEGER  ::   jb, jk         ! dummy loop indices 
    … …  
    147147      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    148148      INTEGER,                      INTENT(in) ::   ib_bdy  ! BDY set index 
    149       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    150       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pssh, phur, phvr  
     149      REAL(wp), DIMENSION(:,:), INTENT(inout) :: pua2d, pva2d 
     150      REAL(wp), DIMENSION(:,:), INTENT(in) ::   pssh, phur, phvr  
    151151 
    152152      INTEGER  ::   jb, igrd                         ! dummy loop indices 
    … …  
    237237      TYPE(OBC_DATA),               INTENT(in) ::   dta  ! OBC external data 
    238238      INTEGER,                      INTENT(in) ::   ib_bdy  ! number of current open boundary set 
    239       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pua2d, pva2d 
    240       REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub2d, pvb2d  
     239      REAL(wp), DIMENSION(:,:),    INTENT(inout) :: pua2d, pva2d 
     240      REAL(wp), DIMENSION(:,:),    INTENT(in) :: pub2d, pvb2d  
    241241      LOGICAL,                      INTENT(in) ::   ll_npo  ! flag for NPO version 
    242242 
    … …  
    271271      !! 
    272272      !!---------------------------------------------------------------------- 
    273       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   zssh ! Sea level 
     273      REAL(wp), DIMENSION(:,:), INTENT(inout) ::   zssh ! Sea level 
    274274      !! 
    275275      INTEGER  ::   ib_bdy, ib, igrd                        ! local integers 
    276       INTEGER  ::   ii, ij, zcoef, zcoef1, zcoef2, ip, jp   !   "       " 
     276      INTEGER  ::   ii, ij, zcoef, ip, jp   !   "       " 
    277277 
    278278      igrd = 1                       ! Everything is at T-points here 
    … …  
    283283            ij = idx_bdy(ib_bdy)%nbj(ib,igrd) 
    284284            ! Set gradient direction: 
    285             zcoef1 = bdytmask(ii-1,ij  ) +  bdytmask(ii+1,ij  ) 
    286             zcoef2 = bdytmask(ii  ,ij-1) +  bdytmask(ii  ,ij+1) 
    287             IF ( zcoef1+zcoef2 == 0 ) THEN 
    288                ! corner 
    289 !               zcoef = tmask(ii-1,ij,1) + tmask(ii+1,ij,1) +  tmask(ii,ij-1,1) +  tmask(ii,ij+1,1) 
    290 !               zssh(ii,ij) = zssh(ii-1,ij  ) * tmask(ii-1,ij  ,1) + & 
    291 !                 &           zssh(ii+1,ij  ) * tmask(ii+1,ij  ,1) + & 
    292 !                 &           zssh(ii  ,ij-1) * tmask(ii  ,ij-1,1) + & 
    293 !                 &           zssh(ii  ,ij+1) * tmask(ii  ,ij+1,1) 
    294                zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
    295                zssh(ii,ij) = zssh(ii-1,ij  ) * bdytmask(ii-1,ij  ) + & 
    296                  &           zssh(ii+1,ij  ) * bdytmask(ii+1,ij  ) + & 
    297                  &           zssh(ii  ,ij-1) * bdytmask(ii  ,ij-1) + & 
    298                  &           zssh(ii  ,ij+1) * bdytmask(ii  ,ij+1) 
    299                zssh(ii,ij) = ( zssh(ii,ij) / MAX( 1, zcoef) ) * tmask(ii,ij,1) 
     285            zcoef = bdytmask(ii-1,ij) + bdytmask(ii+1,ij) +  bdytmask(ii,ij-1) +  bdytmask(ii,ij+1) 
     286            IF ( zcoef == 0 ) THEN 
     287               zssh(ii,ij) = 0._wp 
    300288            ELSE 
    301289               ip = bdytmask(ii+1,ij  ) - bdytmask(ii-1,ij  ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r5602 r7256  
    107107      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    108108      REAL(wp) ::   ztmelts, zdh 
     109#if  defined key_lim2 && ! defined key_lim2_vp && defined key_agrif 
     110     USE ice_2, vt_s => hsnm 
     111     USE ice_2, vt_i => hicm 
     112#endif 
    109113 
    110114      !!------------------------------------------------------------------------------ 
    … …  
    115119      ! 
    116120#if defined key_lim2 
    117       DO jb = 1, idx%nblen(jgrd) 
     121      DO jb = 1, idx%nblenrim(jgrd) 
    118122         ji    = idx%nbi(jb,jgrd) 
    119123         jj    = idx%nbj(jb,jgrd) 
    … …  
    135139 
    136140      DO jl = 1, jpl 
    137          DO jb = 1, idx%nblen(jgrd) 
     141         DO jb = 1, idx%nblenrim(jgrd) 
    138142            ji    = idx%nbi(jb,jgrd) 
    139143            jj    = idx%nbj(jb,jgrd) 
    … …  
    171175 
    172176      DO jl = 1, jpl 
    173          DO jb = 1, idx%nblen(jgrd) 
     177         DO jb = 1, idx%nblenrim(jgrd) 
    174178            ji    = idx%nbi(jb,jgrd) 
    175179            jj    = idx%nbj(jb,jgrd) 
    … …  
    324328                
    325329               jgrd = 2      ! u velocity 
    326                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     330               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    327331                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    328332                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    … …  
    353357                
    354358               jgrd = 3      ! v velocity 
    355                DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
     359               DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
    356360                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    357361                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r4990 r7256  
    7676      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    7777      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    78       INTEGER  ::   iw, ie, is, in, inum, id_dummy         !   -       - 
     78      INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy         !   -       - 
    7979      INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    8080      INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
    … …  
    777777!      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    778778!      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    779       iw = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
    780       ie = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
    781       is = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
    782       in = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
     779      iwe = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
     780      ies = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
     781      iso = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
     782      ino = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
    783783 
    784784      ALLOCATE( nbondi_bdy(nb_bdy)) 
    … …  
    853853               ENDIF 
    854854               ! check if point is in local domain 
    855                IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    856                   & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in       ) THEN 
     855               IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     856                  & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
    857857                  ! 
    858858                  icount = icount  + 1 
    … …  
    890890         com_south_b = 0 
    891891         com_north_b = 0 
     892 
    892893         DO igrd = 1, jpbgrd 
    893894            icount  = 0 
    … …  
    896897               DO ib = 1, nblendta(igrd,ib_bdy) 
    897898                  ! check if point is in local domain and equals ir 
    898                   IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
    899                      & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in .AND.   & 
     899                  IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
     900                     & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND.   & 
    900901                     & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    901902                     ! 
    … …  
    15941595            ELSE 
    15951596               ! This is a corner 
    1596                WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
     1597               IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
    15971598               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) 
    15981599               itest=itest+1 
    … …  
    16081609            ELSE 
    16091610               ! This is a corner 
    1610                WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
     1611               IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
    16111612               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) 
    16121613               itest=itest+1 
    … …  
    16381639            ELSE 
    16391640               ! This is a corner 
    1640                WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
     1641               IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
    16411642               CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) 
    16421643               itest=itest+1 
    … …  
    16521653            ELSE 
    16531654               ! This is a corner 
    1654                WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
     1655               IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
    16551656               CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) 
    16561657               itest=itest+1 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

    r5602 r7256  
    416416      ! Absolute time from model initialization:    
    417417      IF( PRESENT(kit) ) THEN   
    418          z_arg = ( kt + (kit+0.5_wp*(time_add-1)) / REAL(nn_baro,wp) ) * rdt 
     418         z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt 
    419419      ELSE                               
    420420         z_arg = ( kt + time_add ) * rdt 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

    r4990 r7256  
    9191      ! Calculate the cumulate surface Flux z_cflxemp (m3/s) over all the domain 
    9292      ! ----------------------------------------------------------------------- 
    93       z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+rdivisf*fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
     93      z_cflxemp = SUM ( ( emp(:,:)-rnf(:,:)+fwfisf(:,:) ) * bdytmask(:,:) * e1t(:,:) * e2t(:,:) ) / rau0 
    9494      IF( lk_mpp )   CALL mpp_sum( z_cflxemp )     ! sum over the global domain 
    9595 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r5602 r7256  
    6060 
    6161                             indic = 0                ! reset to no error condition 
    62       IF( kstp == nit000 )   CALL iom_init( "nemo")   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
     62      IF( kstp == nit000 )   CALL iom_init( cxios_context )   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    6363      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    64                              CALL iom_setkt( kstp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp 
     64                             CALL iom_setkt( kstp - nit000 + 1, cxios_context )   ! say to iom that we are at time step kstp 
    6565 
    6666      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90

    r7217 r7256  
    185185      ! Horizontal diffusion 
    186186#if defined key_traldf_c3d 
    187    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 3D coefficients ** at T-,U-,V-,W-points 
     187      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 3D coefficients ** at T-,U-,V-,W-points 
    188188#elif defined key_traldf_c2d 
    189    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 2D coefficients ** at T-,U-,V-,W-points 
     189      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 2D coefficients ** at T-,U-,V-,W-points 
    190190#elif defined key_traldf_c1d 
    191    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 1D coefficients ** at T-,U-,V-,W-points 
     191      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)     ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 1D coefficients ** at T-,U-,V-,W-points 
    192192#else 
    193    REAL(wp), PUBLIC                                      ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 0D coefficients ** at T-,U-,V-,W-points 
    194 #endif 
     193      REAL(wp), PUBLIC                                      ::   ahtt_crs, ahtu_crs, ahtv_crs, ahtw_crs   !: ** 0D coefficients ** at T-,U-,V-,W-points 
     194#endif 
     195      REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap_crs 
    195196 
    196197      ! Vertical diffusion 
    … …  
    323324#if defined key_traldf_c3d 
    324325      ALLOCATE( ahtt_crs(jpi_crs,jpj_crs,jpk) , ahtu_crs(jpi_crs,jpj_crs,jpk) , & 
    325               & ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 
     326              & ahtv_crs(jpi_crs,jpj_crs,jpk) , ahtw_crs(jpi_crs,jpj_crs,jpk) , & 
    326327#elif defined key_traldf_c2d 
    327328      ALLOCATE( ahtt_crs(jpi_crs,jpj_crs    ) , ahtu_crs(jpi_crs,jpj_crs    ) , & 
    328               & ahtv_crs(jpi_crs,jpj_crs    ) , ahtw_crs(jpi_crs,jpj_crs    ) , STAT=ierr(13) ) 
     329              & ahtv_crs(jpi_crs,jpj_crs    ) , ahtw_crs(jpi_crs,jpj_crs    ) , & 
    329330#elif defined key_traldf_c1d 
    330       ALLOCATE( ahtt_crs(        jpk) , ahtu_crs(        jpk) , ahtv_crs(        jpk) , ahtw_crs(        jpk) , STAT=ierr(13) ) 
    331 #endif 
     331      ALLOCATE( ahtt_crs(        jpk) , ahtu_crs(        jpk) , ahtv_crs(        jpk) , ahtw_crs(        jpk) , & 
     332#endif 
     333              & r_fact_lap_crs(jpi_crs,jpj_crs,jpk) , STAT=ierr(13) ) 
    332334 
    333335     ALLOCATE( tsb_crs(jpi_crs,jpj_crs,jpk,jpts), tsn_crs(jpi_crs,jpj_crs,jpk,jpts), tsa_crs(jpi_crs,jpj_crs,jpk,jpts),  & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90

    r7222 r7256  
    460460                           ijis = mis_crs(ji) 
    461461                           ijie = mie_crs(ji) 
    462                            zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
    463                            zsfcrs = SUM(                                 zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     462                           zflcrs = SUM( ztabtmp(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
     463                           zsfcrs = SUM(                                   zsurfmsk(ijis:ijie,ijjs:ijje,jk) ) 
    464464                           p_fld_crs(ji,jj,jk) = zflcrs 
    465465                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90

    r7222 r7256  
    2525   USE crsdom 
    2626   USE domvvl 
    27    USE domvvl_crs 
    2827   USE crslbclnk 
    2928   USE iom 
    3029   USE zdfmxl_crs 
    3130   USE eosbn2 
    32    USE zdfevd_crs 
    3331   USE zdftke 
    34    USE zdftke_crs 
    3532 
    3633   USE ieee_arithmetic 
    … …  
    197194      CALL crs_dom_sfc( umask, 'U', e2e3u_crs, e2e3u_msk, p_e2=e2u, p_e3=zfse3u ) 
    198195      CALL crs_dom_sfc( vmask, 'V', e1e3v_crs, e1e3v_msk, p_e1=e1v, p_e3=zfse3v ) 
    199       CALL iom_put("e2e3u_crs",e2e3u_crs) 
    200       CALL iom_put("e2e3u_msk",e2e3u_msk) 
    201       CALL iom_put("e1e3v_crs",e1e3v_crs) 
    202       CALL iom_put("e1e3v_msk",e1e3v_msk) 
     196      !cbr CALL iom_put("e2e3u_crs",e2e3u_crs) 
     197      !CALL iom_put("e2e3u_msk",e2e3u_msk) 
     198      !CALL iom_put("e1e3v_crs",e1e3v_crs) 
     199      !CALL iom_put("e1e3v_msk",e1e3v_msk) 
    203200 
    204201      ! vertical scale factors                                                                                  
    … …  
    233230      ! volume and facvol 
    234231      CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, ocean_volume_crs_t, facvol_t ) 
    235       CALL iom_put("cvol_crs_t",ocean_volume_crs_t) 
     232      !cbr CALL iom_put("cvol_crs_t",ocean_volume_crs_t) 
    236233      ! 
    237234      bt_crs(:,:,:) = ocean_volume_crs_t(:,:,:) * facvol_t(:,:,:)*tmask_crs(:,:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90

    r7217 r7256  
    8888     ! 
    8989 
    90       REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
    91       READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
    92 901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
    93  
    94       REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
    95       READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
    96 902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
    97       IF(lwm) WRITE ( numond, namcrs ) 
    98  
     90     REWIND( numnam_ref )              ! Namelist namrun in reference namelist : Parameters of the run 
     91     READ  ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) 
     92901  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist', lwp ) 
     93 
     94     REWIND( numnam_cfg )              ! Namelist namrun in configuration namelist : Parameters of the run 
     95     READ  ( numnam_cfg, namcrs, IOSTAT = ios, ERR = 902 ) 
     96902  IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in configuration namelist', lwp ) 
     97     IF(lwm) WRITE ( numond, namcrs ) 
     98 
     99     IF( .NOT. lk_crs )ln_crs_top = .FALSE.   
     100  
    99101     IF(lwp) THEN 
    100102        WRITE(numout,*) 
    … …  
    104106        WRITE(numout,*) '   create (=1) a mesh file or not (=0)   nn_msh_crs = ', nn_msh_crs 
    105107        WRITE(numout,*) '   type of Kz coarsening (0,1,2)         nn_crs_kz  = ', nn_crs_kz 
    106         WRITE(numout,*) '   wn coarsened or computed using hdivn  ln_crs_wn  = ', ln_crs_wn 
     108 
     109        IF( ln_crs_wn )THEN  
     110           WRITE(numout,*) '   vertical velocities are coarsened ' 
     111        ELSE 
     112           WRITE(numout,*) '   computed using hdivn ' 
     113        ENDIF 
     114 
     115        IF( .NOT. lk_crs )ln_crs_top = .FALSE.   
     116 
     117        IF( ln_crs_top )THEN ; WRITE(numout,*) '   coarsning of physics activated for outputs and BGC model' 
     118        ELSE                 ; WRITE(numout,*) '   coarsning of physics activated only for outputs'    
     119        ENDIF 
    107120 
    108121        SELECT CASE ( nn_crs_kz ) 
    … …  
    113126           CASE ( 4 ) ; WRITE(numout,*) '   coarsene KZ with MEDIANE(KZ)' 
    114127       END SELECT 
     128 
    115129     ENDIF 
    116130               

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r5602 r7256  
    211211      REAL(wp) ::   zztmp   
    212212      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    213       ! reading initial file 
    214       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    215       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    216       CHARACTER(len=100)            ::   cn_dir 
    217       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    218       INTEGER  ::   ios=0 
    219  
    220       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    221       ! 
    222  
    223       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    224       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    225 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    226       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    227       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    228 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    229       IF(lwm) WRITE ( numond, namtsd ) 
    230213      ! 
    231214      !!---------------------------------------------------------------------- 
    … …  
    233216      IF( nn_timing == 1 )   CALL timing_start('dia_ar5_init') 
    234217      ! 
    235       CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta ) 
     218      CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 
    236219      !                                      ! allocate dia_ar5 arrays 
    237220      IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
    … …  
    249232      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    250233 
    251       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    252       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    253       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     234      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     235      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     236      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    254237      CALL iom_close( inum ) 
     238 
    255239      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    256240      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
    … …  
    267251      ENDIF 
    268252      ! 
    269       CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta ) 
     253      CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 
    270254      ! 
    271255      IF( nn_timing == 1 )   CALL timing_stop('dia_ar5_init') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

    r5602 r7256  
    196196                  DO ji = 1,jpi 
    197197                     ! Elevation 
    198                      ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)           *tmask_i(ji,jj)         
    199 #if defined key_dynspg_ts 
    200                      ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*hur(ji,jj)*umask_i(ji,jj) 
    201                      ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*hvr(ji,jj)*vmask_i(ji,jj) 
    202 #endif 
     198                     ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*tmask_i(ji,jj)         
     199                     ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*umask_i(ji,jj) 
     200                     ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*vmask_i(ji,jj) 
    203201                  END DO 
    204202               END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r5602 r7256  
    3838   PUBLIC   dia_hsb        ! routine called by step.F90 
    3939   PUBLIC   dia_hsb_init   ! routine called by nemogcm.F90 
    40    PUBLIC   dia_hsb_rst    ! routine called by step.F90 
    4140 
    4241   LOGICAL, PUBLIC ::   ln_diahsb   !: check the heat and salt budgets 
    … …  
    8685      !!--------------------------------------------------------------------------- 
    8786      IF( nn_timing == 1 )   CALL timing_start('dia_hsb')       
     87      ! 
    8888      CALL wrk_alloc( jpi,jpj,   z2d0, z2d1 ) 
    8989      ! 
    … …  
    9393      ! 1 - Trends due to forcing ! 
    9494      ! ------------------------- ! 
    95       z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
     95      z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    … …  
    101101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103           z_frc_trd_t = z_frc_trd_t & 
    104               &   + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 
    105           z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
     103          z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
     104          z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
    106105      ENDIF 
    107106 
    … …  
    175174      ENDDO 
    176175 
    177       ! Substract forcing from heat content, salt content and volume variations 
     176      ! ------------------------ ! 
     177      ! 3 -  Drifts              ! 
     178      ! ------------------------ ! 
    178179      zdiff_v1 = zdiff_v1 - frc_v 
    179180      IF( lk_vvl )   zdiff_v2 = zdiff_v2 - frc_v 
    … …  
    188189 
    189190      ! ----------------------- ! 
    190       ! 3 - Diagnostics writing ! 
     191      ! 4 - Diagnostics writing ! 
    191192      ! ----------------------- ! 
    192193      zvol_tot = 0._wp                    ! total ocean volume (calculated with scale factors) 
    … …  
    201202!!gm end 
    202203 
     204      CALL iom_put(   'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
     205      CALL iom_put(   'bgfrctem' , frc_t    * rau0 * rcp * 1.e-20 )   ! hc  - surface forcing (1.e20 J)  
     206      CALL iom_put(   'bgfrchfx' , frc_t    * rau0 * rcp /  &         ! hc  - surface forcing (W/m2)  
     207         &                       ( surf_tot * kt * rdt )        ) 
     208      CALL iom_put(   'bgfrcsal' , frc_s    * 1.e-9    )              ! sc  - surface forcing (psu*km3)  
    203209 
    204210      IF( lk_vvl ) THEN 
    205         CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature variation (C)  
    206         CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    variation (psu) 
    207         CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content variation (1.e20 J)  
    208         CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content variation (psu*km3) 
    209         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    210         CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t variation (km3)   
    211         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    212         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    213         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     211        CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature drift     (C)  
     212        CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    drift     (pss) 
     213        CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content drift    (1.e20 J)  
     214        CALL iom_put( 'bgheatfx' , zdiff_hc * rau0 * rcp /  &         ! Heat flux drift       (W/m2)  
     215           &                       ( surf_tot * kt * rdt )        ) 
     216        CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content drift    (psu*km3) 
     217        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
     218        CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t drift      (km3)   
    214219      ELSE 
    215         CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content variation (C)  
    216         CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content variation (psu) 
    217         CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content variation (1.e20 J)  
    218         CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content variation (psu*km3) 
    219         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    220         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    221         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    222         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     220        CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content drift    (C)  
     221        CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content drift    (pss) 
     222        CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content drift    (1.e20 J)  
     223        CALL iom_put( 'bgheatfx' , zdiff_hc1 * rau0 * rcp /  &        ! Heat flux drift       (W/m2)  
     224           &                       ( surf_tot * kt * rdt )         ) 
     225        CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content drift    (psu*km3) 
     226        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
    223227        CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot )              ! hc  - error due to free surface (C) 
    224228        CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot )              ! sc  - error due to free surface (psu) 
    … …  
    246250     ! 
    247251     INTEGER ::   ji, jj, jk   ! dummy loop indices 
    248      INTEGER ::   id1          ! local integers 
    249252     !!---------------------------------------------------------------------- 
    250253     ! 
    251254     IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    252255        IF( ln_rstart ) THEN                   !* Read the restart file 
    253            !id1 = iom_varid( numror, 'frc_vol'  , ldstop = .FALSE. ) 
    254256           ! 
    255257           IF(lwp) WRITE(numout,*) '~~~~~~~' 
    … …  
    263265              CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 
    264266           ENDIF 
    265            CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini ) 
    266            CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini ) 
    267            CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini ) 
    268            CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini ) 
     267           CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini(:,:) ) 
     268           CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini(:,:,:) ) 
     269           CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     270           CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    269271           IF( .NOT. lk_vvl ) THEN 
    270               CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    271               CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     272              CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     273              CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    272274           ENDIF 
    273275       ELSE 
    … …  
    314316           CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 
    315317        ENDIF 
    316         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini ) 
    317         CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini ) 
    318         CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 
    319         CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 
     318        CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini(:,:) ) 
     319        CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini(:,:,:) ) 
     320        CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     321        CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    320322        IF( .NOT. lk_vvl ) THEN 
    321            CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    322            CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     323           CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     324           CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    323325        ENDIF 
     326 
    324327        ! 
    325328     ENDIF 
    … …  
    340343      !!             - Compute coefficients for conversion 
    341344      !!--------------------------------------------------------------------------- 
    342       INTEGER ::   jk       ! dummy loop indice 
    343345      INTEGER ::   ierror   ! local integer 
    344346      INTEGER ::   ios 
    … …  
    346348      NAMELIST/namhsb/ ln_diahsb 
    347349      !!---------------------------------------------------------------------- 
    348  
    349       IF(lwp) THEN 
    350          WRITE(numout,*) 
    351          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    352          WRITE(numout,*) '~~~~~~~~ ' 
    353       ENDIF 
    354350 
    355351      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist 
    … …  
    362358      IF(lwm) WRITE ( numond, namhsb ) 
    363359 
    364       ! 
    365       IF(lwp) THEN                   ! Control print 
     360      IF(lwp) THEN 
    366361         WRITE(numout,*) 
    367          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    368          WRITE(numout,*) '~~~~~~~~~~~~' 
    369          WRITE(numout,*) '   Namelist namhsb : set hsb parameters' 
    370          WRITE(numout,*) '      Switch for hsb diagnostic (T) or not (F)  ln_diahsb  = ', ln_diahsb 
    371          WRITE(numout,*) 
    372       ENDIF 
    373  
     362         WRITE(numout,*) 'dia_hsb_init' 
     363         WRITE(numout,*) '~~~~~~~~ ' 
     364         WRITE(numout,*) '  check the heat and salt budgets (T) or not (F)       ln_diahsb = ', ln_diahsb 
     365      ENDIF 
     366      ! 
    374367      IF( .NOT. ln_diahsb )   RETURN 
    375368         !      IF( .NOT. lk_mpp_rep ) & 
    … …  
    384377         &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror ) 
    385378      IF( ierror > 0 ) THEN 
    386          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
    387       ENDIF 
    388  
    389       IF(.NOT. lk_vvl ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) 
    390       IF( ierror > 0 ) THEN 
    391          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
     379         CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     380         RETURN 
     381      ENDIF 
     382 
     383      IF( .NOT. lk_vvl ) THEN 
     384         ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj), STAT=ierror ) 
     385         IF( ierror > 0 )   THEN 
     386            CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     387            RETURN 
     388         ENDIF 
    392389      ENDIF 
    393390 
    … …  
    395392      ! 2 - Time independant variables and file opening ! 
    396393      ! ----------------------------------------------- ! 
    397       IF(lwp) WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 
    398       IF(lwp) WRITE(numout,*) '~~~~~~~' 
    399394      surf(:,:) = e1t(:,:) * e2t(:,:) * tmask_i(:,:)      ! masked surface grid cell area 
    400       surf_tot  = glob_sum( surf(:,:) )                                       ! total ocean surface area 
     395      surf_tot  = glob_sum( surf(:,:) )                   ! total ocean surface area 
    401396 
    402397      IF( lk_bdy ) CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' )          

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r5602 r7256  
    145145      ENDIF 
    146146 
    147       IF( .NOT.lk_vvl ) THEN 
    148          CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
    149          CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
    150          CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
    151          CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
    152       ENDIF 
     147      ! Output of initial vertical scale factor 
     148      CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
     149      CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
     150      CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
     151      ! 
     152      CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     153      CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     154      CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     155      CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     156      IF( iom_use("e3tdef") )   & 
     157         CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
     158 
    153159 
    154160      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
    155       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    156161       
    157162      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    243248      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
    244249      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     250                                                            ! Log of eddy diff coef 
     251      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
     252      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    245253 
    246254      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    307315         CALL iom_put( "eken", rke )            
    308316      ENDIF 
    309           
     317      ! 
     318      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
     319      ! 
    310320      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    311321         z3d(:,:,jpk) = 0.e0 
    … …  
    438448      zdt = rdt 
    439449      IF( nacc == 1 ) zdt = rdtmin 
    440       IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!) 
    441       ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time) 
    442       ENDIF 
     450      clop = "x"         ! no use of the mask value (require less cpu time, and otherwise the model crashes) 
    443451#if defined key_diainstant 
    444452      zsto = nwrite * zdt 
    … …  
    10201028         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
    10211029            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
     1030         CALL histdef( id_i, "vovvle3t", "T point thickness"         , "m"      ,   &   ! t-point depth 
     1031            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    10221032      END IF 
    10231033 
    … …  
    10501060      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress 
    10511061      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress 
     1062      IF( lk_vvl ) THEN 
     1063         CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth        
     1064         CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )!  T-cell thickness   
     1065      END IF 
    10521066 
    10531067      ! 3. Close the file 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

    r5602 r7256  
    158158         CASE ( 025 )                                ! ORCA_R025 configuration 
    159159            !                                        ! ======================= 
     160            isrow = 1207 - jpjglo                    !  eORCA025 R025 - Using full isf­extended   
     161                                                     !  domain for reference. - Adjust j­indices 
    160162            ncsnr(1)   = 1    ; ncstt(1)   = 0               ! Caspian + Aral sea 
    161             ncsi1(1)   = 1330 ; ncsj1(1)   = 645 
    162             ncsi2(1)   = 1400 ; ncsj2(1)   = 795 
     163            ncsi1(1)   = 1330 ; ncsj1(1)   = 831 - isrow 
     164            ncsi2(1)   = 1400 ; ncsj2(1)   = 981 - isrow 
    163165            ncsir(1,1) = 1    ; ncsjr(1,1) = 1 
    164166            !                                         
    165167            ncsnr(2)   = 1    ; ncstt(2)   = 0               ! Azov Sea  
    166             ncsi1(2)   = 1284 ; ncsj1(2)   = 722 
    167             ncsi2(2)   = 1304 ; ncsj2(2)   = 747 
     168            ncsi1(2)   = 1284 ; ncsj1(2)   = 908 - isrow 
     169            ncsi2(2)   = 1304 ; ncsj2(2)   = 933 - isrow 
    168170            ncsir(2,1) = 1    ; ncsjr(2,1) = 1 
     171            ! 
     172            ncsnr(3)   = 1    ; ncstt(3)   = 0               ! Great Lakes 
     173            ncsi1(3)   = 775  ; ncsj1(3)   = 866 - isrow 
     174            ncsi2(3)   = 848  ; ncsj2(3)   = 931 - isrow 
     175            ncsir(3,1) = 1    ; ncsjr(3,1) = 1 
     176            !    
     177            ncsnr(4)   = 1    ; ncstt(4)   = 0               ! Lake Victoria 
     178            ncsi1(4)   = 1270 ; ncsj1(4)   = 661 - isrow 
     179            ncsi2(4)   = 1295 ; ncsj2(4)   = 696 - isrow 
     180            ncsir(4,1) = 1    ; ncsjr(4,1) = 1 
     181            !         
    169182            ! 
    170183         END SELECT 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

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

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

    r5602 r7256  
    169169            ! 
    170170            ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait (e2u = 20 km) 
    171             ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
     171            ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  20.e3 
    172172            IF(lwp) WRITE(numout,*) 
    173173            IF(lwp) WRITE(numout,*) '             orca_r1: Gibraltar : e2u reduced to 20 km' 
    174174 
    175175            ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait (e2u = 10 km) 
    176             ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
     176            ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   e2u( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  10.e3 
    177177            IF(lwp) WRITE(numout,*) 
    178178            IF(lwp) WRITE(numout,*) '             orca_r1: Bhosporus : e2u reduced to 10 km' 
    179179 
    180180            ii0 =  44           ;   ii1 =  44        ! Lombok Strait (e1v = 13 km) 
    181             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
     181            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  13.e3 
    182182            IF(lwp) WRITE(numout,*) 
    183183            IF(lwp) WRITE(numout,*) '             orca_r1: Lombok : e1v reduced to 10 km' 
    184184 
    185185            ii0 =  48           ;   ii1 =  48        ! Sumba Strait (e1v = 8 km) [closed from bathy_11 on] 
    186             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
     186            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) =  8.e3 
    187187            IF(lwp) WRITE(numout,*) 
    188188            IF(lwp) WRITE(numout,*) '             orca_r1: Sumba : e1v reduced to 8 km' 
    189189 
    190190            ii0 =  53           ;   ii1 =  53        ! Ombai Strait (e1v = 13 km) 
    191             ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
     191            ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 13.e3 
    192192            IF(lwp) WRITE(numout,*) 
    193193            IF(lwp) WRITE(numout,*) '             orca_r1: Ombai : e1v reduced to 13 km' 
    194194 
    195195            ii0 =  56           ;   ii1 =  56        ! Timor Passage (e1v = 20 km) 
    196             ij0 = 124 + isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
     196            ij0 = 164 - isrow   ;   ij1 = 145 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 20.e3 
    197197            IF(lwp) WRITE(numout,*) 
    198198            IF(lwp) WRITE(numout,*) '             orca_r1: Timor Passage : e1v reduced to 20 km' 
    199199 
    200200            ii0 =  55           ;   ii1 =  55        ! West Halmahera Strait (e1v = 30 km) 
    201             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
     201            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 30.e3 
    202202            IF(lwp) WRITE(numout,*) 
    203203            IF(lwp) WRITE(numout,*) '             orca_r1: W Halmahera : e1v reduced to 30 km' 
    204204 
    205205            ii0 =  58           ;   ii1 =  58        ! East Halmahera Strait (e1v = 50 km) 
    206             ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
     206            ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   e1v( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 50.e3 
    207207            IF(lwp) WRITE(numout,*) 
    208208            IF(lwp) WRITE(numout,*) '             orca_r1: E Halmahera : e1v reduced to 50 km' 
    … …  
    544544         IF ( cp_cfg == 'eel' .AND. jp_cfg == 6 ) THEN    ! for EEL6 configuration only 
    545545            IF( .NOT. Agrif_Root() ) THEN 
    546               zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m) / (ra * rad) 
     546              zphi0 = ppgphi0 - FLOAT( Agrif_Parent(jpjglo)/2)*Agrif_Parent(ppe2_m)   &  
     547                    &           / (ra * rad) 
    547548            ENDIF 
    548549         ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

    r5602 r7256  
    413413         IF(lwp) WRITE(numout,*) '      Gibraltar ' 
    414414         ii0 = 282           ;   ii1 = 283        ! Gibraltar Strait  
    415          ij0 = 201 + isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     415         ij0 = 241 - isrow   ;   ij1 = 241 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    416416 
    417417         IF(lwp) WRITE(numout,*) '      Bhosporus ' 
    418418         ii0 = 314           ;   ii1 = 315        ! Bhosporus Strait  
    419          ij0 = 208 + isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     419         ij0 = 248 - isrow   ;   ij1 = 248 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    420420 
    421421         IF(lwp) WRITE(numout,*) '      Makassar (Top) ' 
    422422         ii0 =  48           ;   ii1 =  48        ! Makassar Strait (Top)  
    423          ij0 = 149 + isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     423         ij0 = 189 - isrow   ;   ij1 = 190 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    424424 
    425425         IF(lwp) WRITE(numout,*) '      Lombok ' 
    426426         ii0 =  44           ;   ii1 =  44        ! Lombok Strait  
    427          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     427         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    428428 
    429429         IF(lwp) WRITE(numout,*) '      Ombai ' 
    430430         ii0 =  53           ;   ii1 =  53        ! Ombai Strait  
    431          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     431         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    432432 
    433433         IF(lwp) WRITE(numout,*) '      Timor Passage ' 
    434434         ii0 =  56           ;   ii1 =  56        ! Timor Passage  
    435          ij0 = 124 + isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
     435         ij0 = 164 - isrow   ;   ij1 = 165 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp   
    436436 
    437437         IF(lwp) WRITE(numout,*) '      West Halmahera ' 
    438438         ii0 =  58           ;   ii1 =  58        ! West Halmahera Strait  
    439          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     439         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    440440 
    441441         IF(lwp) WRITE(numout,*) '      East Halmahera ' 
    442442         ii0 =  55           ;   ii1 =  55        ! East Halmahera Strait  
    443          ij0 = 141 + isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
     443         ij0 = 181 - isrow   ;   ij1 = 182 - isrow   ;   fmask( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp   
    444444         ! 
    445445      ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r5602 r7256  
    665665         ht(:,:) = ht(:,:) + fse3t_n(:,:,jk) * tmask(:,:,jk) 
    666666      END DO 
    667  
    668       ! Write outputs 
    669       ! ============= 
    670       CALL iom_put(     "e3t" , fse3t_n  (:,:,:) ) 
    671       CALL iom_put(     "e3u" , fse3u_n  (:,:,:) ) 
    672       CALL iom_put(     "e3v" , fse3v_n  (:,:,:) ) 
    673       CALL iom_put(     "e3w" , fse3w_n  (:,:,:) ) 
    674       CALL iom_put( "tpt_dep" , fsde3w_n (:,:,:) ) 
    675       IF( iom_use("e3tdef") )   & 
    676          CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    677667 
    678668      ! write restart file 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r4990 r7256  
    215215         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    216216         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
     217         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
     218         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )      
    217219      ENDIF 
    218220       

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r5602 r7256  
    219219         &  ppsur == pp_to_be_computed           ) THEN 
    220220         ! 
     221#if defined key_agrif 
     222         za1  = (  ppdzmin - pphmax / FLOAT(jpkdta-1)  )                                                   & 
     223            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * (  LOG( COSH( (jpkdta - ppkth) / ppacr) )& 
     224            &                                                      - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     225#else 
    221226         za1  = (  ppdzmin - pphmax / FLOAT(jpkm1)  )                                                      & 
    222227            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * (  LOG( COSH( (jpk - ppkth) / ppacr) )      & 
    223228            &                                                   - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
     229#endif 
    224230         za0  = ppdzmin - za1 *              TANH( (1-ppkth) / ppacr ) 
    225231         zsur =   - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr )  ) 
    … …  
    236242              WRITE(numout,*) '            Uniform grid with ',jpk-1,' layers' 
    237243              WRITE(numout,*) '            Total depth    :', zhmax 
     244#if defined key_agrif 
     245              WRITE(numout,*) '            Layer thickness:', zhmax/(jpkdta-1) 
     246#else 
    238247              WRITE(numout,*) '            Layer thickness:', zhmax/(jpk-1) 
     248#endif 
    239249         ELSE 
    240250            IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN 
    … …  
    260270      ! Reference z-coordinate (depth - scale factor at T- and W-points) 
    261271      ! ====================== 
    262       IF( ppkth == 0._wp ) THEN            !  uniform vertical grid        
     272      IF( ppkth == 0._wp ) THEN            !  uniform vertical grid  
     273#if defined key_agrif 
     274         za1 = zhmax / FLOAT(jpkdta-1)  
     275#else 
    263276         za1 = zhmax / FLOAT(jpk-1)  
     277#endif 
    264278         DO jk = 1, jpk 
    265279            zw = FLOAT( jk ) 
    … …  
    18701884             iim1 = MAX( ji-1, 1 ) 
    18711885             ijm1 = MAX( jj-1, 1 ) 
    1872              IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) +              & 
    1873         &         bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 
    1874                zenv(ji,jj) = rn_sbot_min 
     1886             IF( ( + bathy(iim1,ijp1) + bathy(ji,ijp1) + bathy(iip1,ijp1)  & 
     1887                &  + bathy(iim1,jj  )                  + bathy(iip1,jj  )  & 
     1888                &  + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1)  ) > 0._wp ) THEN 
     1889                zenv(ji,jj) = rn_sbot_min 
    18751890             ENDIF 
    18761891           ENDIF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

    r5602 r7256  
    9797      IF( nn_timing == 1 )  CALL timing_start('div_cur') 
    9898      ! 
    99       CALL wrk_alloc( jpi  , jpj+2, zwu               ) 
    100       CALL wrk_alloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     99      CALL wrk_alloc( jpi  , jpj+2, zwu  ) 
     100      CALL wrk_alloc( jpi+2, jpj  , zwv ) 
    101101      ! 
    102102      IF( kt == nit000 ) THEN 
    … …  
    236236      CALL lbc_lnk( hdivn, 'T', 1. )   ;   CALL lbc_lnk( rotn , 'F', 1. )    ! lateral boundary cond. (no sign change) 
    237237      ! 
    238       CALL wrk_dealloc( jpi  , jpj+2, zwu               ) 
    239       CALL wrk_dealloc( jpi+4, jpj  , zwv, kistart = -1 ) 
     238      CALL wrk_dealloc( jpi  , jpj+2, zwu ) 
     239      CALL wrk_dealloc( jpi+2, jpj  , zwv ) 
    240240      ! 
    241241      IF( nn_timing == 1 )  CALL timing_stop('div_cur') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

    r5602 r7256  
    266266               ! Add volume filter correction: compatibility with tracer advection scheme 
    267267               ! => time filter + conservation correction (only at the first level) 
    268                fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
    269                               &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     268               IF ( nn_isf == 0) THEN   ! if no ice shelf melting 
     269                  fse3t_b(:,:,1) = fse3t_b(:,:,1) - atfp * rdt * r1_rau0 * ( emp_b(:,:) - emp(:,:) & 
     270                                 &                                          -rnf_b(:,:) + rnf(:,:) ) * tmask(:,:,1) 
     271               ELSE                     ! if ice shelf melting 
     272                  DO jj = 1,jpj 
     273                     DO ji = 1,jpi 
     274                        jk = mikt(ji,jj) 
     275                        fse3t_b(ji,jj,jk) = fse3t_b(ji,jj,jk) - atfp * rdt * r1_rau0                       & 
     276                                          &                          * ( (emp_b(ji,jj)    - emp(ji,jj)   ) & 
     277                                          &                            - (rnf_b(ji,jj)    - rnf(ji,jj)   ) & 
     278                                          &                            + (fwfisf_b(ji,jj) - fwfisf(ji,jj)) ) * tmask(ji,jj,jk) 
     279                     END DO 
     280                  END DO 
     281               END IF 
    270282            ENDIF 
    271283            ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

    r5602 r7256  
    187187      ! 
    188188                                                       ! time offset in steps for bdy data update 
    189       IF (.NOT.ln_bt_fw) THEN ; noffset=-2*nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
     189      IF (.NOT.ln_bt_fw) THEN ; noffset=-nn_baro ; ELSE ;  noffset = 0 ; ENDIF 
    190190      ! 
    191191      IF( kt == nit000 ) THEN                !* initialisation 
    … …  
    454454      !                                         ! Surface net water flux and rivers 
    455455      IF (ln_bt_fw) THEN 
    456          zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) 
     456         zssh_frc(:,:) = zraur * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) 
    457457      ELSE 
    458458         zssh_frc(:,:) = zraur * z1_2 * (  emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:)   & 
    459                 &                        + rdivisf * ( fwfisf(:,:) + fwfisf_b(:,:) )       ) 
     459                &                        + fwfisf(:,:) + fwfisf_b(:,:)                     ) 
    460460      ENDIF 
    461461#if defined key_asminc 
    … …  
    465465      ENDIF 
    466466#endif 
    467       !                                   !* Fill boundary data arrays with AGRIF 
    468       !                                   ! ------------------------------------- 
     467      !                                   !* Fill boundary data arrays for AGRIF 
     468      !                                   ! ------------------------------------ 
    469469#if defined key_agrif 
    470470         IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) 
    … …  
    523523         ! Update only tidal forcing at open boundaries 
    524524#if defined key_tide 
    525          IF ( lk_bdy .AND. lk_tide )      CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
    526          IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, koffset=noffset ) 
     525         IF ( lk_bdy .AND. lk_tide ) CALL bdy_dta_tides( kt, kit=jn, time_offset=(noffset+1) ) 
     526         IF ( ln_tide_pot .AND. lk_tide ) CALL upd_tide( kt, kit=jn, time_offset=noffset ) 
    527527#endif 
    528528         ! 
    … …  
    900900#if defined key_agrif 
    901901      ! Save time integrated fluxes during child grid integration 
    902       ! (used to update coarse grid transports) 
    903       ! Useless with 2nd order momentum schemes 
     902      ! (used to update coarse grid transports at next time step) 
    904903      ! 
    905904      IF ( (.NOT.Agrif_Root()).AND.(ln_bt_fw) ) THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r5602 r7256  
    323323            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
    324324            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    325                &                                      / ( ze3va * rau0 )  
     325               &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1) 
    326326#else 
    327327            va(ji,jj,1) = vb(ji,jj,1) & 
    328328               &                   + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    329                &                                                       / ( fse3v(ji,jj,1) * rau0     ) ) 
     329               &                                      / ( fse3v(ji,jj,1) * rau0     ) * vmask(ji,jj,1) ) 
    330330#endif 
    331331         END DO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

    r5602 r7256  
    3131   USE bdydyn2d        ! bdy_ssh routine 
    3232#if defined key_agrif 
    33    USE agrif_opa_update 
    3433   USE agrif_opa_interp 
    3534#endif 
    … …  
    268267      ELSE                                         !** Leap-Frog time-stepping: Asselin filter + swap 
    269268         sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) )     ! before <-- now filtered 
    270          IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:) - emp(:,:) - rnf_b(:,:) + rnf(:,:) ) * ssmask(:,:) 
     269         IF( lk_vvl ) sshb(:,:) = sshb(:,:) - atfp * rdt / rau0 * ( emp_b(:,:)    - emp(:,:)    & 
     270                                &                                 - rnf_b(:,:)    + rnf(:,:)    & 
     271                                &                                 + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) 
    271272         sshn(:,:) = ssha(:,:)                           ! now <-- after 
    272273      ENDIF 
    273       ! 
    274       ! Update velocity at AGRIF zoom boundaries 
    275 #if defined key_agrif 
    276       IF ( .NOT.Agrif_Root() ) CALL Agrif_Update_Dyn( kt ) 
    277 #endif 
    278274      ! 
    279275      IF(ln_ctl)   CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb  - : ', mask1=tmask, ovlap=1 ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    r5602 r7256  
    120120      ! first entry with narea for this processor is left hand interior index 
    121121      ! last  entry                               is right hand interior index 
    122       jj = jpj/2 
     122      jj = nlcj/2 
    123123      nicbdi = -1 
    124124      nicbei = -1 
    … …  
    136136      ! 
    137137      ! repeat for j direction 
    138       ji = jpi/2 
     138      ji = nlci/2 
    139139      nicbdj = -1 
    140140      nicbej = -1 
    … …  
    153153      ! special for east-west boundary exchange we save the destination index 
    154154      i1 = MAX( nicbdi-1, 1) 
    155       i3 = INT( src_calving(i1,jpj/2) ) 
     155      i3 = INT( src_calving(i1,nlcj/2) ) 
    156156      jj = INT( i3/nicbpack ) 
    157157      ricb_left = REAL( i3 - nicbpack*jj, wp ) 
    158158      i1 = MIN( nicbei+1, jpi ) 
    159       i3 = INT( src_calving(i1,jpj/2) ) 
     159      i3 = INT( src_calving(i1,nlcj/2) ) 
    160160      jj = INT( i3/nicbpack ) 
    161161      ricb_right = REAL( i3 - nicbpack*jj, wp ) 
    … …  
    196196         WRITE(numicb,*) 'berg left       ', ricb_left 
    197197         WRITE(numicb,*) 'berg right      ', ricb_right 
    198          jj = jpj/2 
     198         jj = nlcj/2 
    199199         WRITE(numicb,*) "central j line:" 
    200200         WRITE(numicb,*) "i processor" 
    … …  
    202202         WRITE(numicb,*) "i point" 
    203203         WRITE(numicb,*) (INT(src_calving(ji,jj)), ji=1,jpi) 
    204          ji = jpi/2 
     204         ji = nlci/2 
    205205         WRITE(numicb,*) "central i line:" 
    206206         WRITE(numicb,*) "j processor" 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r7217 r7256  
    100100      CHARACTER(len=*), INTENT(in)  :: cdname 
    101101#if defined key_iomput 
    102       TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
    103       CHARACTER(len=19) :: cldate  
    104       CHARACTER(len=10) :: clname 
    105       INTEGER           ::   ji 
     102#if ! defined key_xios2 
     103      TYPE(xios_time)     :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
     104      CHARACTER(len=19)   :: cldate  
     105#else 
     106      TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0) 
     107      TYPE(xios_date)     :: start_date 
     108#endif 
     109      CHARACTER(len=10)   :: clname 
     110      INTEGER             :: ji 
    106111      ! 
    107112      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
    108113      !!---------------------------------------------------------------------- 
    109  
     114#if ! defined key_xios2 
    110115      ALLOCATE( z_bnds(jpk,2) ) 
     116#else 
     117      ALLOCATE( z_bnds(2,jpk) ) 
     118#endif 
    111119 
    112120      clname = cdname 
    … …  
    116124 
    117125      ! calendar parameters 
     126#if ! defined key_xios2 
    118127      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    119128      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") 
    … …  
    123132      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
    124133      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    125  
     134#else 
     135      ! Calendar type is now defined in xml file  
     136      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     137      CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 
     138          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     139      CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), & 
     140          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     141      CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), & 
     142          &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
     143      END SELECT 
     144#endif 
    126145      ! horizontal grid definition 
     146 
    127147      CALL set_scalar 
    128148 
    … …  
    176196 
    177197      ! Add vertical grid bounds 
     198#if ! defined key_xios2 
    178199      z_bnds(:      ,1) = gdepw_1d(:) 
    179200      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
    180201      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
     202#else 
     203      z_bnds(1      ,:) = gdepw_1d(:) 
     204      z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
     205      z_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
     206#endif 
     207 
    181208      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
    182209      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
    183210      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
    184       z_bnds(:    ,2) = gdept_1d(:) 
    185       z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
    186       z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
     211 
     212#if ! defined key_xios2 
     213      z_bnds(:    ,2)  = gdept_1d(:) 
     214      z_bnds(2:jpk,1)  = gdept_1d(1:jpkm1) 
     215      z_bnds(1    ,1)  = gdept_1d(1) - e3w_1d(1) 
     216#else 
     217      z_bnds(2,:    )  = gdept_1d(:) 
     218      z_bnds(1,2:jpk)  = gdept_1d(1:jpkm1) 
     219      z_bnds(1,1    )  = gdept_1d(1) - e3w_1d(1) 
     220#endif 
    187221      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
     222 
    188223 
    189224# if defined key_floats 
    … …  
    11621197      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    11631198      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    1164       LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    1165  
     1199#if ! defined key_xios2 
     1200     LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
     1201#else 
     1202      LOGICAL,  DIMENSION(:) , OPTIONAL, INTENT(in) ::   mask 
     1203#endif 
     1204 
     1205#if ! defined key_xios2 
    11661206      IF ( xios_is_valid_domain     (cdid) ) THEN 
    11671207         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11701210            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
    11711211            &    bounds_lat=bounds_lat, area=area ) 
    1172       ENDIF 
    1173  
     1212     ENDIF 
    11741213      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    11751214         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    11791218            &    bounds_lat=bounds_lat, area=area ) 
    11801219      ENDIF 
     1220 
     1221#else 
     1222      IF ( xios_is_valid_domain     (cdid) ) THEN 
     1223         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1224            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1225            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1226            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 
     1227     ENDIF 
     1228      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
     1229         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
     1230            &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
     1231            &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
     1232            &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 
     1233      ENDIF 
     1234#endif 
    11811235      CALL xios_solve_inheritance() 
    11821236 
    11831237   END SUBROUTINE iom_set_domain_attr 
     1238 
     1239#if defined key_xios2 
     1240  SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 
     1241     CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
     1242     INTEGER                  , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj 
     1243 
     1244     IF ( xios_is_valid_zoom_domain     (cdid) ) THEN 
     1245         CALL xios_set_zoom_domain_attr     ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni,    & 
     1246           &   nj=nj) 
     1247    ENDIF 
     1248  END SUBROUTINE iom_set_zoom_domain_attr 
     1249#endif 
    11841250 
    11851251 
    … …  
    11891255      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
    11901256      IF ( PRESENT(paxis) ) THEN 
     1257#if ! defined key_xios2 
    11911258         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
    11921259         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
     1260#else 
     1261         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1262         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
     1263#endif 
    11931264      ENDIF 
    11941265      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    … …  
    11971268   END SUBROUTINE iom_set_axis_attr 
    11981269 
    1199  
    12001270   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 
    12011271      CHARACTER(LEN=*)          , INTENT(in) ::   cdid 
    1202       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op 
    1203       CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset 
    1204       IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    1205       IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1272#if ! defined key_xios2 
     1273      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_op 
     1274      CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_offset 
     1275#else 
     1276      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_op 
     1277      TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_offset 
     1278#endif 
     1279      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr       & 
     1280    &     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1281      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr  & 
     1282    &                    ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    12061283      CALL xios_solve_inheritance() 
    12071284   END SUBROUTINE iom_set_field_attr 
    1208  
    12091285 
    12101286   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 
    … …  
    12191295   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 
    12201296      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid 
    1221       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq 
     1297      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix 
     1298#if ! defined key_xios2 
     1299      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::    output_freq 
     1300#else 
     1301      TYPE(xios_duration)   ,OPTIONAL , INTENT(out) :: output_freq 
     1302#endif   
    12221303      LOGICAL                                 ::   llexist1,llexist2,llexist3 
    12231304      !--------------------------------------------------------------------- 
    12241305      IF( PRESENT( name        ) )   name = ''          ! default values 
    12251306      IF( PRESENT( name_suffix ) )   name_suffix = '' 
     1307#if ! defined key_xios2 
    12261308      IF( PRESENT( output_freq ) )   output_freq = '' 
     1309#else 
     1310      IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0) 
     1311#endif 
    12271312      IF ( xios_is_valid_file     (cdid) ) THEN 
    12281313         CALL xios_solve_inheritance() 
    … …  
    12451330      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    12461331      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask 
     1332#if ! defined key_xios2 
    12471333      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask ) 
    12481334      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask ) 
     1335#else 
     1336      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask ) 
     1337      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 
     1338#endif 
    12491339      CALL xios_solve_inheritance() 
    12501340   END SUBROUTINE iom_set_grid_attr 
    … …  
    12881378      ni=nlei-nldi+1 ; nj=nlej-nldj+1 
    12891379 
    1290       CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1380#if ! defined key_xios2 
     1381     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
     1382#else 
     1383     CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1384#endif      
    12911385      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    12921386      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    … …  
    13021396         END SELECT 
    13031397         ! 
     1398#if ! defined key_xios2 
    13041399         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. ) 
     1400#else 
     1401         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. ) 
     1402#endif   
    13051403         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 
    13061404      ENDIF 
    … …  
    14361534      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
    14371535 
     1536      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
     1537#if ! defined key_xios2 
    14381538      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    14391539      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    … …  
    14411541         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    14421542      ! 
    1443       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    14441543      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
     1544#else 
     1545! Pas teste : attention aux indices ! 
     1546      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
     1547      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
     1548      CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
     1549         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
     1550       CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
     1551#endif 
     1552 
    14451553      CALL iom_update_file_name('ptr') 
    14461554      ! 
    … …  
    14561564      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    14571565      !!---------------------------------------------------------------------- 
     1566#if ! defined key_xios2 
    14581567      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
     1568#else 
     1569      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 
     1570#endif 
    14591571      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
    14601572       
    14611573      zz=REAL(narea,wp) 
    14621574      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1463  
     1575       
    14641576   END SUBROUTINE set_scalar 
    14651577 
    … …  
    14851597      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings 
    14861598      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings 
     1599#if  defined key_xios2 
     1600      TYPE(xios_duration)            ::   f_op, f_of 
     1601#endif 
     1602  
    14871603      !!---------------------------------------------------------------------- 
    14881604      !  
    14891605      ! frequency of the call of iom_put (attribut: freq_op) 
    1490       WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 
    1491       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts') 
    1492       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op = cl1//'ts', freq_offset='0ts') 
    1493       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
    1494       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
     1606#if ! defined key_xios2 
     1607      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 
     1608      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op=cl1//'ts', freq_offset='0ts') 
     1609      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op=cl1//'ts', freq_offset='0ts') 
     1610      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1611      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
     1612#else 
     1613      f_op%timestep = 1        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 
     1614      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of) 
     1615      f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of) 
     1616      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of) 
     1617      f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of) 
     1618#endif 
    14951619        
    14961620      ! output file names (attribut: name) 
    … …  
    15141638         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    15151639         CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
     1640#if ! defined key_xios2 
    15161641         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 
     1642#else 
     1643         CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 
     1644#endif 
    15171645         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    15181646         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 
    … …  
    15941722               ENDIF 
    15951723               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 
     1724#if ! defined key_xios2 
    15961725               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 
     1726#else 
     1727               CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 
     1728#endif 
    15971729               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         ) 
    15981730               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 
    … …  
    16231755      REAL(wp)           ::   zsec 
    16241756      LOGICAL            ::   llexist 
    1625       !!---------------------------------------------------------------------- 
     1757#if  defined key_xios2 
     1758      TYPE(xios_duration)   ::   output_freq  
     1759#endif       
     1760      !!---------------------------------------------------------------------- 
     1761 
    16261762 
    16271763      DO jn = 1,2 
    1628  
     1764#if ! defined key_xios2 
    16291765         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq ) 
     1766#else 
     1767         output_freq = xios_duration(0,0,0,0,0,0) 
     1768         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq ) 
     1769#endif 
    16301770         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname ) 
    16311771 
    … …  
    16381778            END DO 
    16391779 
     1780#if ! defined key_xios2 
    16401781            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16411782            DO WHILE ( idx /= 0 )  
    … …  
    16501791               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    16511792            END DO 
    1652  
     1793#else 
     1794            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1795            DO WHILE ( idx /= 0 )  
     1796              IF ( output_freq%timestep /= 0) THEN 
     1797                  WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts'  
     1798                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1799              ELSE IF ( output_freq%hour /= 0 ) THEN 
     1800                  WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h'  
     1801                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1802              ELSE IF ( output_freq%day /= 0 ) THEN 
     1803                  WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d'  
     1804                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1805              ELSE IF ( output_freq%month /= 0 ) THEN    
     1806                  WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m'  
     1807                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1808              ELSE IF ( output_freq%year /= 0 ) THEN    
     1809                  WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y'  
     1810                  itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
     1811              ELSE 
     1812                  CALL ctl_stop('error in the name of file id '//TRIM(cdid),   & 
     1813                     & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 
     1814              ENDIF 
     1815              clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 
     1816              idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
     1817            END DO 
     1818#endif 
    16531819            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 
    16541820            DO WHILE ( idx /= 0 )  
    … …  
    16791845            END DO 
    16801846 
     1847            IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    16811848            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    16821849            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    17261893      ENDIF 
    17271894       
     1895!$AGRIF_DO_NOT_TREAT       
     1896! Should be fixed in the conv 
    17281897      IF( llfull ) THEN  
    17291898         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 
    … …  
    17361905         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run 
    17371906      ENDIF 
     1907!$AGRIF_END_DO_NOT_TREAT       
    17381908 
    17391909   END FUNCTION iom_sdate 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r5602 r7256  
    1111   !!                            the BDY/OBC communications 
    1212   !!            3.4  ! 2012-12  (R. Bourdalle-Badie and G. Reffray)  add a C1D case   
     13   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1314   !!---------------------------------------------------------------------- 
    1415#if defined key_mpp_mpi 
    … …  
    2425 
    2526   INTERFACE lbc_lnk_multi 
    26       MODULE PROCEDURE mpp_lnk_2d_9 
     27      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2728   END INTERFACE 
    2829 
    … …  
    8081   END INTERFACE 
    8182 
     83   INTERFACE lbc_lnk_multi 
     84      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     85   END INTERFACE 
     86 
    8287   INTERFACE lbc_bdy_lnk 
    8388      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    8792      MODULE PROCEDURE lbc_lnk_2d_e 
    8893   END INTERFACE 
     94    
     95   TYPE arrayptr 
     96      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     97   END TYPE arrayptr 
     98   PUBLIC   arrayptr 
    8999 
    90100   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
    91101   PUBLIC   lbc_lnk_e  
     102   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    92103   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    93104   PUBLIC   lbc_lnk_icb 
    … …  
    171182      ! 
    172183   END SUBROUTINE lbc_lnk_2d 
     184    
     185   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     186      !! 
     187      INTEGER :: num_fields 
     188      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     189      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     190      !                                                               ! = T , U , V , F , W and I points 
     191      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     192      !                                                               ! =  1. , the sign is kept 
     193      ! 
     194      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     195      ! 
     196      DO ii = 1, num_fields 
     197        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     198      END DO      
     199      ! 
     200   END SUBROUTINE lbc_lnk_2d_multiple 
     201 
     202   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     203      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     204      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     205      !!--------------------------------------------------------------------- 
     206      ! Second 2D array on which the boundary condition is applied 
     207      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     208      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     209      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     210      ! define the nature of ptab array grid-points 
     211      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     212      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     213      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     214      ! =-1 the sign change across the north fold boundary 
     215      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     216      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     217      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     218      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     219      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     220      !! 
     221      !!--------------------------------------------------------------------- 
     222 
     223      !!The first array 
     224      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     225 
     226      !! Look if more arrays to process 
     227      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     228      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     229      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     230      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     231      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     232      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     233      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     234      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     235 
     236   END SUBROUTINE lbc_lnk_2d_9 
     237 
     238 
     239 
     240 
    173241 
    174242#else 
    … …  
    372440      !     
    373441   END SUBROUTINE lbc_lnk_2d 
     442    
     443   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     444      !! 
     445      INTEGER :: num_fields 
     446      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     447      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     448      !                                                               ! = T , U , V , F , W and I points 
     449      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     450      !                                                               ! =  1. , the sign is kept 
     451      ! 
     452      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     453      ! 
     454      DO ii = 1, num_fields 
     455        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     456      END DO      
     457      ! 
     458   END SUBROUTINE lbc_lnk_2d_multiple 
     459 
     460   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     461      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     462      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     463      !!--------------------------------------------------------------------- 
     464      ! Second 2D array on which the boundary condition is applied 
     465      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     466      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     467      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     468      ! define the nature of ptab array grid-points 
     469      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     470      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     471      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     472      ! =-1 the sign change across the north fold boundary 
     473      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     474      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     475      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     476      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     477      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     478      !! 
     479      !!--------------------------------------------------------------------- 
     480 
     481      !!The first array 
     482      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     483 
     484      !! Look if more arrays to process 
     485      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     486      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     487      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     488      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     489      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     490      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     491      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     492      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     493 
     494   END SUBROUTINE lbc_lnk_2d_9 
     495 
    374496 
    375497#endif 
    … …  
    441563   !!====================================================================== 
    442564END MODULE lbclnk 
     565 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6772 r7256  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
    … …  
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
    … …  
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mppscatter, mppgather, mppgatheri 
    7578   PUBLIC   mpp_ini_ice, mpp_ini_znl 
    … …  
    7881   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7982   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     83   PUBLIC   mpprank 
    8084 
    8185   TYPE arrayptr 
    8286      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8387   END TYPE arrayptr 
     88   PUBLIC   arrayptr 
    8489    
    8590   !! * Interfaces 
    … …  
    105110   INTERFACE mpp_maxloc 
    106111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     112   END INTERFACE 
     113 
     114   INTERFACE mpp_max_multiple 
     115      MODULE PROCEDURE mppmax_real_multiple 
    107116   END INTERFACE 
    108117 
    … …  
    298307      ENDIF 
    299308 
     309#if defined key_agrif 
     310      IF (Agrif_Root()) THEN 
     311         CALL Agrif_MPI_Init(mpi_comm_opa) 
     312      ELSE 
     313         CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 
     314      ENDIF 
     315#endif 
     316 
    300317      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    301318      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
    … …  
    724741      ! ----------------------- 
    725742      ! 
    726       DO ii = 1 , num_fields 
    727743         !First Array 
    728          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    729             ! 
    730             SELECT CASE ( jpni ) 
    731             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    732             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    733             END SELECT 
    734             ! 
    735          ENDIF 
    736          ! 
    737       END DO 
     744      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     745         ! 
     746         SELECT CASE ( jpni ) 
     747         CASE ( 1 )     ;    
     748             DO ii = 1 , num_fields   
     749                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     750             END DO 
     751         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     752         END SELECT 
     753         ! 
     754      ENDIF 
     755        ! 
    738756       
    739757      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    … …  
    17031721   END SUBROUTINE mppmax_real 
    17041722 
     1723   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1724      !!---------------------------------------------------------------------- 
     1725      !!                  ***  routine mppmax_real  *** 
     1726      !! 
     1727      !! ** Purpose :   Maximum 
     1728      !! 
     1729      !!---------------------------------------------------------------------- 
     1730      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1731      INTEGER , INTENT(in   )           ::   NUM 
     1732      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1733      !! 
     1734      INTEGER  ::   ierror, localcomm 
     1735      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1736      !!---------------------------------------------------------------------- 
     1737      ! 
     1738      CALL wrk_alloc(NUM , zwork) 
     1739      localcomm = mpi_comm_opa 
     1740      IF( PRESENT(kcom) )   localcomm = kcom 
     1741      ! 
     1742      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1743      ptab = zwork 
     1744      CALL wrk_dealloc(NUM , zwork) 
     1745      ! 
     1746   END SUBROUTINE mppmax_real_multiple 
     1747 
    17051748 
    17061749   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    … …  
    25972640   END SUBROUTINE mpp_lbc_north_2d 
    25982641 
     2642   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2643      !!--------------------------------------------------------------------- 
     2644      !!                   ***  routine mpp_lbc_north_2d  *** 
     2645      !! 
     2646      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2647      !!              in mpp configuration in case of jpn1 > 1 
     2648      !!              (for multiple 2d arrays ) 
     2649      !! 
     2650      !! ** Method  :   North fold condition and mpp with more than one proc 
     2651      !!              in i-direction require a specific treatment. We gather 
     2652      !!              the 4 northern lines of the global domain on 1 processor 
     2653      !!              and apply lbc north-fold on this sub array. Then we 
     2654      !!              scatter the north fold array back to the processors. 
     2655      !! 
     2656      !!---------------------------------------------------------------------- 
     2657      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2658      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2659      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2660      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2661      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2662      !!                                                             ! =  1. , the sign is kept 
     2663      INTEGER ::   ji, jj, jr, jk 
     2664      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2665      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2666      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2667      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2668      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2669      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2670      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2671      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2672      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2673      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2674      INTEGER :: istatus(mpi_status_size) 
     2675      INTEGER :: iflag 
     2676      !!---------------------------------------------------------------------- 
     2677      ! 
     2678      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   &  
     2679            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2680      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2681      ! 
     2682      ijpj   = 4 
     2683      ijpjm1 = 3 
     2684      ! 
     2685       
     2686      DO jk = 1, num_fields 
     2687         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2688            ij = jj - nlcj + ijpj 
     2689            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2690         END DO 
     2691      END DO 
     2692      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2693      itaille = jpi * ijpj 
     2694                                                                   
     2695      IF ( l_north_nogather ) THEN 
     2696         ! 
     2697         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2698         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2699         ! 
     2700         ztabr(:,:,:) = 0 
     2701         ztabl(:,:,:) = 0 
     2702 
     2703         DO jk = 1, num_fields 
     2704            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2705               ij = jj - nlcj + ijpj 
     2706               DO ji = nfsloop, nfeloop 
     2707                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2708               END DO 
     2709            END DO 
     2710         END DO 
     2711 
     2712         DO jr = 1,nsndto 
     2713            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2714               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2715            ENDIF 
     2716         END DO 
     2717         DO jr = 1,nsndto 
     2718            iproc = nfipproc(isendto(jr),jpnj) 
     2719            IF(iproc .ne. -1) THEN 
     2720               ilei = nleit (iproc+1) 
     2721               ildi = nldit (iproc+1) 
     2722               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2723            ENDIF 
     2724            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2725              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2726              DO jk = 1 , num_fields 
     2727                 DO jj = 1, ijpj 
     2728                    DO ji = ildi, ilei 
     2729                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2730                    END DO 
     2731                 END DO 
     2732              END DO 
     2733            ELSE IF (iproc .eq. (narea-1)) THEN 
     2734              DO jk = 1, num_fields 
     2735                 DO jj = 1, ijpj 
     2736                    DO ji = ildi, ilei 
     2737                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2738                    END DO 
     2739                 END DO 
     2740              END DO 
     2741            ENDIF 
     2742         END DO 
     2743         IF (l_isend) THEN 
     2744            DO jr = 1,nsndto 
     2745               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2746                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2747               ENDIF 
     2748            END DO 
     2749         ENDIF 
     2750         ! 
     2751         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2752            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2753         END DO 
     2754         ! 
     2755         DO jk = 1, num_fields 
     2756            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2757               ij = jj - nlcj + ijpj 
     2758               DO ji = 1, nlci 
     2759                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2760               END DO 
     2761            END DO 
     2762         END DO 
     2763          
     2764         ! 
     2765      ELSE 
     2766         ! 
     2767         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2768            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2769         ! 
     2770         ztab(:,:,:) = 0.e0 
     2771         DO jk = 1, num_fields 
     2772            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2773               iproc = nrank_north(jr) + 1 
     2774               ildi = nldit (iproc) 
     2775               ilei = nleit (iproc) 
     2776               iilb = nimppt(iproc) 
     2777               DO jj = 1, ijpj 
     2778                  DO ji = ildi, ilei 
     2779                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2780                  END DO 
     2781               END DO 
     2782            END DO 
     2783         END DO 
     2784          
     2785         DO ji = 1, num_fields 
     2786            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2787         END DO 
     2788         ! 
     2789         DO jk = 1, num_fields 
     2790            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2791               ij = jj - nlcj + ijpj 
     2792               DO ji = 1, nlci 
     2793                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2794               END DO 
     2795            END DO 
     2796         END DO 
     2797         ! 
     2798         ! 
     2799      ENDIF 
     2800      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2801      DEALLOCATE( ztabl, ztabr ) 
     2802      ! 
     2803   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25992804 
    26002805   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r5601 r7256  
    201201       
    202202#endif 
    203       IF(lwp) THEN 
    204          WRITE(numout,*) 
    205          WRITE(numout,*) '           defines mpp subdomains' 
    206          WRITE(numout,*) '           ----------------------' 
    207          WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
    208          WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
    209          ifreq = 4 
    210          il1   = 1 
    211          DO jn = 1, (jpni-1)/ifreq+1 
    212             il2 = MIN( jpni, il1+ifreq-1 ) 
    213             WRITE(numout,*) 
    214             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    215             DO jj = jpnj, 1, -1 
    216                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    217                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    218                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    219                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    220             END DO 
    221             WRITE(numout,9201) (ji,ji = il1,il2) 
    222             il1 = il1+ifreq 
    223          END DO 
    224  9200    FORMAT('     ***',20('*************',a3)) 
    225  9203    FORMAT('     *     ',20('         *   ',a3)) 
    226  9201    FORMAT('        ',20('   ',i3,'          ')) 
    227  9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    228       ENDIF 
    229  
    230       zidom = nreci 
    231       DO ji = 1, jpni 
    232          zidom = zidom + ilcit(ji,1) - nreci 
    233       END DO 
    234       IF(lwp) WRITE(numout,*) 
    235       IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
    236        
    237       zjdom = nrecj 
    238       DO jj = 1, jpnj 
    239          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    240       END DO 
    241       IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
    242       IF(lwp) WRITE(numout,*) 
    243        
    244203 
    245204      !  2. Index arrays for subdomains 
    … …  
    313272         nlejt(jn) = nlej 
    314273      END DO 
    315        
    316  
    317       ! 4. From global to local 
     274 
     275      ! 4. Subdomain print 
     276      ! ------------------ 
     277       
     278      IF(lwp) WRITE(numout,*) 
     279      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     280      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     281      IF(lwp) WRITE(numout,*) 
     282      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     283      IF(lwp) WRITE(numout,*) 
     284      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     285      zidom = nreci 
     286      DO ji = 1, jpni 
     287         zidom = zidom + ilcit(ji,1) - nreci 
     288      END DO 
     289      IF(lwp) WRITE(numout,*) 
     290      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     291 
     292      zjdom = nrecj 
     293      DO jj = 1, jpnj 
     294         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     295      END DO 
     296      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     297      IF(lwp) WRITE(numout,*) 
     298 
     299      IF(lwp) THEN 
     300         ifreq = 4 
     301         il1   = 1 
     302         DO jn = 1, (jpni-1)/ifreq+1 
     303            il2 = MIN( jpni, il1+ifreq-1 ) 
     304            WRITE(numout,*) 
     305            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     306            DO jj = jpnj, 1, -1 
     307               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     308               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     309               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     310               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     311               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     312            END DO 
     313            WRITE(numout,9201) (ji,ji = il1,il2) 
     314            il1 = il1+ifreq 
     315         END DO 
     316 9200     FORMAT('     ***',20('*************',a3)) 
     317 9203     FORMAT('     *     ',20('         *   ',a3)) 
     318 9201     FORMAT('        ',20('   ',i3,'          ')) 
     319 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     320 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     321      ENDIF 
     322 
     323      ! 5. From global to local 
    318324      ! ----------------------- 
    319325 
    … …  
    322328 
    323329 
    324       ! 5. Subdomain neighbours 
     330      ! 6. Subdomain neighbours 
    325331      ! ---------------------- 
    326332 
    … …  
    445451         WRITE(numout,*) ' nimpp  = ', nimpp 
    446452         WRITE(numout,*) ' njmpp  = ', njmpp 
    447          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    448          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    449          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    450          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     453         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     454         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     455         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     456         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     457         WRITE(numout,*) 
    451458      ENDIF 
    452459 
    … …  
    455462      ! Prepare mpp north fold 
    456463 
    457       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     464      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    458465         CALL mpp_ini_north 
    459       END IF 
     466         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     467      ENDIF 
    460468 
    461469      ! Prepare NetCDF output file (if necessary) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r6772 r7256  
    309309         ENDIF 
    310310 
     311         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    311312         isurf = 0 
    312313         DO jj = 1, ilj 
    … …  
    315316            END DO 
    316317         END DO 
     318 
    317319         IF(isurf /= 0) THEN 
    318320            icont = icont + 1 
    … …  
    326328 
    327329      nfipproc(:,:) = ipproc(:,:) 
    328  
    329330 
    330331      ! Control 
    … …  
    434435      ii = iin(narea) 
    435436      ij = ijn(narea) 
     437 
     438      ! set default neighbours 
     439      noso = ioso(ii,ij) 
     440      nowe = iowe(ii,ij) 
     441      noea = ioea(ii,ij) 
     442      nono = iono(ii,ij)  
     443      npse = iose(ii,ij) 
     444      npsw = iosw(ii,ij) 
     445      npne = ione(ii,ij) 
     446      npnw = ionw(ii,ij) 
     447 
     448      ! check neighbours location 
    436449      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    437450         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    517530      IF (lwp) THEN 
    518531         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     532         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    519533         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    520534         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    529543      END IF 
    530544 
    531       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    532  
    533       ! Prepare mpp north fold 
    534  
    535       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    536          CALL mpp_ini_north 
    537          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    538       ENDIF 
    539  
    540545      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    541546      ! In this case the important thing is that npolj /= 0 
    … …  
    554559      ENDIF 
    555560 
     561      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     562 
     563      IF(lwp) THEN 
     564         WRITE(numout,*) ' nproc  = ', nproc 
     565         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     566         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     567         WRITE(numout,*) ' nbondi = ', nbondi 
     568         WRITE(numout,*) ' nbondj = ', nbondj 
     569         WRITE(numout,*) ' npolj  = ', npolj 
     570         WRITE(numout,*) ' nperio = ', nperio 
     571         WRITE(numout,*) ' nlci   = ', nlci 
     572         WRITE(numout,*) ' nlcj   = ', nlcj 
     573         WRITE(numout,*) ' nimpp  = ', nimpp 
     574         WRITE(numout,*) ' njmpp  = ', njmpp 
     575         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     576         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     577         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     578         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     579         WRITE(numout,*) 
     580      ENDIF 
     581 
     582      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     583 
     584      ! Prepare mpp north fold 
     585 
     586      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     587         CALL mpp_ini_north 
     588         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     589      ENDIF 
     590 
    556591      ! Prepare NetCDF output file (if necessary) 
    557592      CALL mpp_init_ioipsl 
    558593 
    559       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    560  
    561       IF(lwp) THEN 
    562          WRITE(numout,*) ' nproc=  ',nproc 
    563          WRITE(numout,*) ' nowe=   ',nowe 
    564          WRITE(numout,*) ' noea=   ',noea 
    565          WRITE(numout,*) ' nono=   ',nono 
    566          WRITE(numout,*) ' noso=   ',noso 
    567          WRITE(numout,*) ' nbondi= ',nbondi 
    568          WRITE(numout,*) ' nbondj= ',nbondj 
    569          WRITE(numout,*) ' npolj=  ',npolj 
    570          WRITE(numout,*) ' nperio= ',nperio 
    571          WRITE(numout,*) ' nlci=   ',nlci 
    572          WRITE(numout,*) ' nlcj=   ',nlcj 
    573          WRITE(numout,*) ' nimpp=  ',nimpp 
    574          WRITE(numout,*) ' njmpp=  ',njmpp 
    575          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    576          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    577          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    578          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    579       ENDIF 
    580594 
    581595   END SUBROUTINE mpp_init2 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r4990 r7256  
    157157         END DO 
    158158      ENDIF 
     159 
     160      ! ORCA R1: Take the minimum between aeiw  and aeiv0 
     161      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 
     162         DO jj = 2, jpjm1 
     163            DO ji = fs_2, fs_jpim1   ! vector opt. 
     164               aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 
     165            END DO 
     166         END DO 
     167      ENDIF 
     168 
    159169      CALL lbc_lnk( aeiw, 'W', 1. )      ! lateral boundary condition on aeiw  
    160170 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6772 r7256  
    189189            DO jj = 2, jpjm1 
    190190               DO ji = fs_2, fs_jpim1   ! vector opt. 
    191                   IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    192                   IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
    193                   IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
    194                   IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
    195                   IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
    196                   IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
     191               zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj)  , hmlpt  (ji+1,jj  ), 5._wp)   & 
     192                  &            - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       )   ) 
     193               zhmlpv(ji,jj) = ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp)   & 
     194                  &            - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)       )   ) 
    197195               ENDDO 
    198196            ENDDO 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp_crs.F90

    r6772 r7256  
    329329      CALL crs_lbc_lnk( wslpi_crs, 'W', -1. )      ;      CALL crs_lbc_lnk( wslpj_crs, 'W', -1. ) 
    330330      ! 
    331       CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
    332       CALL iom_put("uslp_crs",uslp_crs) 
    333       CALL iom_put("vslp_crs",vslp_crs) 
    334       CALL iom_swap( "nemo" )    ! swap on the coarse grid 
     331      !CALL iom_swap( "nemo_crs" )    ! swap on the coarse grid 
     332      !CALL iom_put("uslp_crs",uslp_crs) 
     333      !CALL iom_put("vslp_crs",vslp_crs) 
     334      !CALL iom_swap( "nemo" )    ! swap on the coarse grid 
    335335      ! 
    336336      CALL wrk_dealloc( jpi_crs,jpj_crs,jpk, zwz, zww, zdzr, zgru, zgrv ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r4147 r7256  
    4141 
    4242   REAL(wp), PUBLIC ::   rldf                        !: multiplicative factor of diffusive coefficient 
     43   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap 
    4344                                                     !: Needed to define the ratio between passive and active tracer diffusion coef.  
    4445 
    … …  
    9293      !!                 ***  FUNCTION ldftra_oce_alloc  *** 
    9394     !!---------------------------------------------------------------------- 
    94      INTEGER, DIMENSION(3) :: ierr 
     95     INTEGER, DIMENSION(4) :: ierr 
    9596     !!---------------------------------------------------------------------- 
    9697     ierr(:) = 0 
    … …  
    116117# endif 
    117118#endif 
     119      ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 
    118120      ldftra_oce_alloc = MAXVAL( ierr ) 
    119121      IF( ldftra_oce_alloc /= 0 )   CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90

    r3294 r7256  
    1313!   'key_traldf_c3d' :                 aht: 3D coefficient 
    1414#       define   fsahtt(i,j,k)   rldf * ahtt(i,j,k) 
    15 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) 
     15#       define   fsahtu(i,j,k)   rldf * ahtu(i,j,k) * r_fact_lap(i,j,k) 
    1616#       define   fsahtv(i,j,k)   rldf * ahtv(i,j,k) 
    1717#       define   fsahtw(i,j,k)   rldf * ahtw(i,j,k) 
    … …  
    1919!   'key_traldf_c2d' :                 aht: 2D coefficient 
    2020#       define   fsahtt(i,j,k)   rldf * ahtt(i,j) 
    21 #       define   fsahtu(i,j,k)   rldf * ahtu(i,j) 
     21#       define   fsahtu(i,j,k)   rldf * ahtu(i,j) * r_fact_lap(i,j,k) 
    2222#       define   fsahtv(i,j,k)   rldf * ahtv(i,j) 
    2323#       define   fsahtw(i,j,k)   rldf * ahtw(i,j) 
    … …  
    2525!   'key_traldf_c1d' :                aht: 1D coefficient 
    2626#       define   fsahtt(i,j,k)   rldf * ahtt(k) 
    27 #       define   fsahtu(i,j,k)   rldf * ahtu(k) 
     27#       define   fsahtu(i,j,k)   rldf * ahtu(k) * r_fact_lap(i,j,k) 
    2828#       define   fsahtv(i,j,k)   rldf * ahtv(k) 
    2929#       define   fsahtw(i,j,k)   rldf * ahtw(k) 
    … …  
    3131!   Default option :             aht: Constant coefficient 
    3232#      define   fsahtt(i,j,k)   rldf * aht0 
    33 #      define   fsahtu(i,j,k)   rldf * aht0 
     33#      define   fsahtu(i,j,k)   rldf * aht0 * r_fact_lap(i,j,k) 
    3434#      define   fsahtv(i,j,k)   rldf * aht0 
    3535#      define   fsahtw(i,j,k)   rldf * aht0 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

    r4624 r7256  
    99   !!             -   ! 2001-06  (M. Vancoppenolle) LIM 3.0 
    1010   !!             -   ! 2006-08  (G. Madec)  cleaning for surface module 
     11   !!            3.6  ! 2016-01  (C. Rousset) new parameterization for sea ice albedo 
    1112   !!---------------------------------------------------------------------- 
    1213 
    … …  
    2930 
    3031   INTEGER  ::   albd_init = 0      !: control flag for initialization 
    31    REAL(wp) ::   zzero     = 0.e0   ! constant values 
    32    REAL(wp) ::   zone      = 1.e0   !    "       " 
    33  
    34    REAL(wp) ::   c1     = 0.05    ! constants values 
    35    REAL(wp) ::   c2     = 0.10    !    "        " 
    36    REAL(wp) ::   rmue   = 0.40    !  cosine of local solar altitude 
    37  
     32   
     33   REAL(wp) ::   rmue     = 0.40    !  cosine of local solar altitude 
     34   REAL(wp) ::   ralb_oce = 0.066   ! ocean or lead albedo (Pegau and Paulson, Ann. Glac. 2001) 
     35   REAL(wp) ::   c1       = 0.05    ! snow thickness (only for nn_ice_alb=0) 
     36   REAL(wp) ::   c2       = 0.10    !  "        " 
     37   REAL(wp) ::   rcloud   = 0.06    ! cloud effect on albedo (only-for nn_ice_alb=0) 
     38  
    3839   !                             !!* namelist namsbc_alb 
    39    REAL(wp) ::   rn_cloud         !  cloudiness effect on snow or ice albedo (Grenfell & Perovich, 1984) 
    40 #if defined key_lim3 
    41    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    42 #else 
    43    REAL(wp) ::   rn_albice        !  albedo of melting ice in the arctic and antarctic (Shine & Hendersson-Sellers) 
    44 #endif 
    45    REAL(wp) ::   rn_alphd         !  coefficients for linear interpolation used to compute 
    46    REAL(wp) ::   rn_alphdi        !  albedo between two extremes values (Pyane, 1972) 
    47    REAL(wp) ::   rn_alphc         !  
     40   INTEGER  ::   nn_ice_alb 
     41   REAL(wp) ::   rn_albice 
    4842 
    4943   !!---------------------------------------------------------------------- 
    … …  
    5953      !!           
    6054      !! ** Purpose :   Computation of the albedo of the snow/ice system  
    61       !!                as well as the ocean one 
    6255      !!        
    63       !! ** Method  : - Computation of the albedo of snow or ice (choose the  
    64       !!                rignt one by a large number of tests 
    65       !!              - Computation of the albedo of the ocean 
    66       !! 
    67       !! References :   Shine and Hendersson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     56      !! ** Method  :   Two schemes are available (from namelist parameter nn_ice_alb) 
     57      !!                  0: the scheme is that of Shine & Henderson-Sellers (JGR 1985) for clear-skies 
     58      !!                  1: the scheme is "home made" (for cloudy skies) and based on Brandt et al. (J. Climate 2005) 
     59      !!                                                                           and Grenfell & Perovich (JGR 2004) 
     60      !!                Description of scheme 1: 
     61      !!                  1) Albedo dependency on ice thickness follows the findings from Brandt et al (2005) 
     62      !!                     which are an update of Allison et al. (JGR 1993) ; Brandt et al. 1999 
     63      !!                     0-5cm  : linear function of ice thickness 
     64      !!                     5-150cm: log    function of ice thickness 
     65      !!                     > 150cm: constant 
     66      !!                  2) Albedo dependency on snow thickness follows the findings from Grenfell & Perovich (2004) 
     67      !!                     i.e. it increases as -EXP(-snw_thick/0.02) during freezing and -EXP(-snw_thick/0.03) during melting 
     68      !!                  3) Albedo dependency on clouds is speculated from measurements of Grenfell and Perovich (2004) 
     69      !!                     i.e. cloudy-clear albedo depend on cloudy albedo following a 2d order polynomial law 
     70      !!                  4) The needed 4 parameters are: dry and melting snow, freezing ice and bare puddled ice 
     71      !! 
     72      !! ** Note    :   The parameterization from Shine & Henderson-Sellers presents several misconstructions: 
     73      !!                  1) ice albedo when ice thick. tends to 0 is different than ocean albedo 
     74      !!                  2) for small ice thick. covered with some snow (<3cm?), albedo is larger  
     75      !!                     under melting conditions than under freezing conditions 
     76      !!                  3) the evolution of ice albedo as a function of ice thickness shows   
     77      !!                     3 sharp inflexion points (at 5cm, 100cm and 150cm) that look highly unrealistic 
     78      !! 
     79      !! References :   Shine & Henderson-Sellers 1985, JGR, 90(D1), 2243-2250. 
     80      !!                Brandt et al. 2005, J. Climate, vol 18 
     81      !!                Grenfell & Perovich 2004, JGR, vol 109  
    6882      !!---------------------------------------------------------------------- 
    6983      REAL(wp), INTENT(in   ), DIMENSION(:,:,:) ::   pt_ice      !  ice surface temperature (Kelvin) 
    … …  
    7387      REAL(wp), INTENT(  out), DIMENSION(:,:,:) ::   pa_ice_os   !  albedo of ice under overcast sky 
    7488      !! 
    75       INTEGER  ::   ji, jj, jl    ! dummy loop indices 
    76       INTEGER  ::   ijpl          ! number of ice categories (3rd dim of ice input arrays) 
    77       REAL(wp) ::   zalbpsnm      ! albedo of ice under clear sky when snow is melting 
    78       REAL(wp) ::   zalbpsnf      ! albedo of ice under clear sky when snow is freezing 
    79       REAL(wp) ::   zalbpsn       ! albedo of snow/ice system when ice is coverd by snow 
    80       REAL(wp) ::   zalbpic       ! albedo of snow/ice system when ice is free of snow 
    81       REAL(wp) ::   zithsn        ! = 1 for hsn >= 0 ( ice is cov. by snow ) ; = 0 otherwise (ice is free of snow) 
    82       REAL(wp) ::   zitmlsn       ! = 1 freezinz snow (pt_ice >=rt0_snow) ; = 0 melting snow (pt_ice<rt0_snow) 
    83       REAL(wp) ::   zihsc1        ! = 1 hsn <= c1 ; = 0 hsn > c1 
    84       REAL(wp) ::   zihsc2        ! = 1 hsn >= c2 ; = 0 hsn < c2 
    85       !! 
    86       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalbfz    ! = rn_alphdi for freezing ice ; = rn_albice for melting ice 
    87       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zficeth   !  function of ice thickness 
     89      INTEGER  ::   ji, jj, jl         ! dummy loop indices 
     90      INTEGER  ::   ijpl               ! number of ice categories (3rd dim of ice input arrays) 
     91      REAL(wp)            ::   ralb_im, ralb_sf, ralb_sm, ralb_if 
     92      REAL(wp)            ::   zswitch, z1_c1, z1_c2 
     93      REAL(wp)                            ::   zalb_sm, zalb_sf, zalb_st ! albedo of snow melting, freezing, total 
     94      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb, zalb_it             ! intermediate variable & albedo of ice (snow free) 
    8895      !!--------------------------------------------------------------------- 
    89        
     96 
    9097      ijpl = SIZE( pt_ice, 3 )                     ! number of ice categories 
    91  
    92       CALL wrk_alloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     98       
     99      CALL wrk_alloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    93100 
    94101      IF( albd_init == 0 )   CALL albedo_init      ! initialization  
    95102 
    96       !--------------------------- 
    97       !  Computation of  zficeth 
    98       !--------------------------- 
    99       ! ice free of snow and melts 
    100       WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalbfz(:,:,:) = rn_albice 
    101       ELSE WHERE                                              ;   zalbfz(:,:,:) = rn_alphdi 
    102       END  WHERE 
    103  
    104       WHERE     ( 1.5  < ph_ice                     )  ;  zficeth = zalbfz 
    105       ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zficeth = 0.472  + 2.0 * ( zalbfz - 0.472 ) * ( ph_ice - 1.0 ) 
    106       ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zficeth = 0.2467 + 0.7049 * ph_ice              & 
    107          &                                                                 - 0.8608 * ph_ice * ph_ice     & 
    108          &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
    109       ELSE WHERE                                       ;  zficeth = 0.1    + 3.6    * ph_ice 
    110       END WHERE 
    111  
    112 !!gm old code 
    113 !      DO jl = 1, ijpl 
    114 !         DO jj = 1, jpj 
    115 !            DO ji = 1, jpi 
    116 !               IF( ph_ice(ji,jj,jl) > 1.5 ) THEN 
    117 !                  zficeth(ji,jj,jl) = zalbfz(ji,jj,jl) 
    118 !               ELSEIF( ph_ice(ji,jj,jl) > 1.0  .AND. ph_ice(ji,jj,jl) <= 1.5 ) THEN 
    119 !                  zficeth(ji,jj,jl) = 0.472 + 2.0 * ( zalbfz(ji,jj,jl) - 0.472 ) * ( ph_ice(ji,jj,jl) - 1.0 ) 
    120 !               ELSEIF( ph_ice(ji,jj,jl) > 0.05 .AND. ph_ice(ji,jj,jl) <= 1.0 ) THEN 
    121 !                  zficeth(ji,jj,jl) = 0.2467 + 0.7049 * ph_ice(ji,jj,jl)                               & 
    122 !                     &                    - 0.8608 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl)                 & 
    123 !                     &                    + 0.3812 * ph_ice(ji,jj,jl) * ph_ice(ji,jj,jl) * ph_ice (ji,jj,jl) 
    124 !               ELSE 
    125 !                  zficeth(ji,jj,jl) = 0.1 + 3.6 * ph_ice(ji,jj,jl)  
    126 !               ENDIF 
    127 !            END DO 
    128 !         END DO 
    129 !      END DO 
    130 !!gm end old code 
    131        
    132       !-----------------------------------------------  
    133       !    Computation of the snow/ice albedo system  
    134       !-------------------------- --------------------- 
    135        
    136       !    Albedo of snow-ice for clear sky. 
    137       !-----------------------------------------------     
    138       DO jl = 1, ijpl 
    139          DO jj = 1, jpj 
    140             DO ji = 1, jpi 
    141                !  Case of ice covered by snow.              
    142                !                                        !  freezing snow         
    143                zihsc1   = 1.0 - MAX( zzero , SIGN( zone , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
    144                zalbpsnf = ( 1.0 - zihsc1 ) * (  zficeth(ji,jj,jl)                                             & 
    145                   &                           + ph_snw(ji,jj,jl) * ( rn_alphd - zficeth(ji,jj,jl) ) / c1  )   & 
    146                   &     +         zihsc1   * rn_alphd   
    147                !                                        !  melting snow                 
    148                zihsc2   = MAX( zzero , SIGN( zone , ph_snw(ji,jj,jl) - c2 ) ) 
    149                zalbpsnm = ( 1.0 - zihsc2 ) * ( rn_albice + ph_snw(ji,jj,jl) * ( rn_alphc - rn_albice ) / c2 )   & 
    150                   &     +         zihsc2   *   rn_alphc  
    151                ! 
    152                zitmlsn  =  MAX( zzero , SIGN( zone , pt_ice(ji,jj,jl) - rt0_snow ) )    
    153                zalbpsn  =  zitmlsn * zalbpsnm + ( 1.0 - zitmlsn ) * zalbpsnf 
    154              
    155                !  Case of ice free of snow. 
    156                zalbpic  = zficeth(ji,jj,jl)  
    157              
    158                ! albedo of the system    
    159                zithsn   = 1.0 - MAX( zzero , SIGN( zone , - ph_snw(ji,jj,jl) ) ) 
    160                pa_ice_cs(ji,jj,jl) =  zithsn * zalbpsn + ( 1.0 - zithsn ) *  zalbpic 
     103       
     104      SELECT CASE ( nn_ice_alb ) 
     105 
     106      !------------------------------------------ 
     107      !  Shine and Henderson-Sellers (1985) 
     108      !------------------------------------------ 
     109      CASE( 0 ) 
     110        
     111         ralb_sf = 0.80       ! dry snow 
     112         ralb_sm = 0.65       ! melting snow 
     113         ralb_if = 0.72       ! bare frozen ice 
     114         ralb_im = rn_albice  ! bare puddled ice  
     115          
     116         !  Computation of ice albedo (free of snow) 
     117         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb(:,:,:) = ralb_im 
     118         ELSE WHERE                                              ;   zalb(:,:,:) = ralb_if 
     119         END  WHERE 
     120       
     121         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     122         ELSE WHERE( 1.0  < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = 0.472  + 2.0 * ( zalb - 0.472 ) * ( ph_ice - 1.0 ) 
     123         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.0 )  ;  zalb_it = 0.2467 + 0.7049 * ph_ice              & 
     124            &                                                                 - 0.8608 * ph_ice * ph_ice     & 
     125            &                                                                 + 0.3812 * ph_ice * ph_ice * ph_ice 
     126         ELSE WHERE                                       ;  zalb_it = 0.1    + 3.6    * ph_ice 
     127         END WHERE 
     128      
     129         DO jl = 1, ijpl 
     130            DO jj = 1, jpj 
     131               DO ji = 1, jpi 
     132                  ! freezing snow 
     133                  ! no effect of underlying ice layer IF snow thickness > c1. Albedo does not depend on snow thick if > c2 
     134                  !                                        !  freezing snow         
     135                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ( ph_snw(ji,jj,jl) - c1 ) ) ) 
     136                  zalb_sf   = ( 1._wp - zswitch ) * (  zalb_it(ji,jj,jl)  & 
     137                     &                           + ph_snw(ji,jj,jl) * ( ralb_sf - zalb_it(ji,jj,jl) ) / c1  )   & 
     138                     &        +         zswitch   * ralb_sf   
     139 
     140                  ! melting snow 
     141                  ! no effect of underlying ice layer. Albedo does not depend on snow thick IF > c2 
     142                  zswitch   = MAX( 0._wp , SIGN( 1._wp , ph_snw(ji,jj,jl) - c2 ) ) 
     143                  zalb_sm = ( 1._wp - zswitch ) * ( ralb_im + ph_snw(ji,jj,jl) * ( ralb_sm - ralb_im ) / c2 )   & 
     144                      &     +         zswitch   *   ralb_sm  
     145                  ! 
     146                  ! snow albedo 
     147                  zswitch  =  MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     148                  zalb_st  =  zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     149                
     150                  ! Ice/snow albedo 
     151                  zswitch   = 1._wp - MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     152                  pa_ice_cs(ji,jj,jl) =  zswitch * zalb_st + ( 1._wp - zswitch ) * zalb_it(ji,jj,jl) 
     153                  ! 
     154               END DO 
    161155            END DO 
    162156         END DO 
    163       END DO 
    164        
    165       !    Albedo of snow-ice for overcast sky. 
    166       !----------------------------------------------   
    167       pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rn_cloud       ! Oberhuber correction 
    168       ! 
    169       CALL wrk_dealloc( jpi,jpj,ijpl, zalbfz, zficeth ) 
     157 
     158         pa_ice_os(:,:,:) = pa_ice_cs(:,:,:) + rcloud       ! Oberhuber correction for overcast sky 
     159 
     160      !------------------------------------------ 
     161      !  New parameterization (2016) 
     162      !------------------------------------------ 
     163      CASE( 1 )  
     164 
     165         ralb_im = rn_albice  ! bare puddled ice 
     166! compilation of values from literature 
     167         ralb_sf = 0.85      ! dry snow 
     168         ralb_sm = 0.75      ! melting snow 
     169         ralb_if = 0.60      ! bare frozen ice 
     170! Perovich et al 2002 (Sheba) => the only dataset for which all types of ice/snow were retrieved 
     171!         ralb_sf = 0.85       ! dry snow 
     172!         ralb_sm = 0.72       ! melting snow 
     173!         ralb_if = 0.65       ! bare frozen ice 
     174! Brandt et al 2005 (East Antarctica) 
     175!         ralb_sf = 0.87      ! dry snow 
     176!         ralb_sm = 0.82      ! melting snow 
     177!         ralb_if = 0.54      ! bare frozen ice 
     178!  
     179         !  Computation of ice albedo (free of snow) 
     180         z1_c1 = 1. / ( LOG(1.5) - LOG(0.05) )  
     181         z1_c2 = 1. / 0.05 
     182         WHERE     ( ph_snw == 0._wp .AND. pt_ice >= rt0_ice )   ;   zalb = ralb_im 
     183         ELSE WHERE                                              ;   zalb = ralb_if 
     184         END  WHERE 
     185          
     186         WHERE     ( 1.5  < ph_ice                     )  ;  zalb_it = zalb 
     187         ELSE WHERE( 0.05 < ph_ice .AND. ph_ice <= 1.5 )  ;  zalb_it = zalb     + ( 0.18 - zalb     ) * z1_c1 *  & 
     188            &                                                                     ( LOG(1.5) - LOG(ph_ice) ) 
     189         ELSE WHERE                                       ;  zalb_it = ralb_oce + ( 0.18 - ralb_oce ) * z1_c2 * ph_ice 
     190         END WHERE 
     191 
     192         z1_c1 = 1. / 0.02 
     193         z1_c2 = 1. / 0.03 
     194         !  Computation of the snow/ice albedo 
     195         DO jl = 1, ijpl 
     196            DO jj = 1, jpj 
     197               DO ji = 1, jpi 
     198                  zalb_sf = ralb_sf - ( ralb_sf - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c1 ); 
     199                  zalb_sm = ralb_sm - ( ralb_sm - zalb_it(ji,jj,jl)) * EXP( - ph_snw(ji,jj,jl) * z1_c2 ); 
     200 
     201                   ! snow albedo 
     202                  zswitch = MAX( 0._wp , SIGN( 1._wp , pt_ice(ji,jj,jl) - rt0_snow ) )    
     203                  zalb_st = zswitch * zalb_sm + ( 1._wp - zswitch ) * zalb_sf 
     204 
     205                  ! Ice/snow albedo    
     206                  zswitch             = MAX( 0._wp , SIGN( 1._wp , - ph_snw(ji,jj,jl) ) ) 
     207                  pa_ice_os(ji,jj,jl) = ( 1._wp - zswitch ) * zalb_st + zswitch *  zalb_it(ji,jj,jl) 
     208 
     209              END DO 
     210            END DO 
     211         END DO 
     212         ! Effect of the clouds (2d order polynomial) 
     213         pa_ice_cs = pa_ice_os - ( - 0.1010 * pa_ice_os * pa_ice_os + 0.1933 * pa_ice_os - 0.0148 );  
     214 
     215      END SELECT 
     216       
     217      CALL wrk_dealloc( jpi,jpj,ijpl, zalb, zalb_it ) 
    170218      ! 
    171219   END SUBROUTINE albedo_ice 
    … …  
    181229      REAL(wp), DIMENSION(:,:), INTENT(out) ::   pa_oce_cs   !  albedo of ocean under clear sky 
    182230      !! 
    183       REAL(wp) ::   zcoef   ! local scalar 
    184       !!---------------------------------------------------------------------- 
    185       ! 
    186       zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )      ! Parameterization of Briegled and Ramanathan, 1982  
    187       pa_oce_cs(:,:) = zcoef                
    188       pa_oce_os(:,:)  = 0.06                         ! Parameterization of Kondratyev, 1969 and Payne, 1972 
     231      REAL(wp) :: zcoef  
     232      !!---------------------------------------------------------------------- 
     233      ! 
     234      zcoef = 0.05 / ( 1.1 * rmue**1.4 + 0.15 )   ! Parameterization of Briegled and Ramanathan, 1982 
     235      pa_oce_cs(:,:) = zcoef  
     236      pa_oce_os(:,:) = 0.06                       ! Parameterization of Kondratyev, 1969 and Payne, 1972 
    189237      ! 
    190238   END SUBROUTINE albedo_oce 
    … …  
    200248      !!---------------------------------------------------------------------- 
    201249      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    202       NAMELIST/namsbc_alb/ rn_cloud, rn_albice, rn_alphd, rn_alphdi, rn_alphc 
     250      NAMELIST/namsbc_alb/ nn_ice_alb, rn_albice  
    203251      !!---------------------------------------------------------------------- 
    204252      ! 
    … …  
    219267         WRITE(numout,*) '~~~~~~~' 
    220268         WRITE(numout,*) '   Namelist namsbc_alb : albedo ' 
    221          WRITE(numout,*) '      correction for snow and ice albedo                  rn_cloud  = ', rn_cloud 
    222          WRITE(numout,*) '      albedo of melting ice in the arctic and antarctic   rn_albice = ', rn_albice 
    223          WRITE(numout,*) '      coefficients for linear                             rn_alphd  = ', rn_alphd 
    224          WRITE(numout,*) '      interpolation used to compute albedo                rn_alphdi = ', rn_alphdi 
    225          WRITE(numout,*) '      between two extremes values (Pyane, 1972)           rn_alphc  = ', rn_alphc 
     269         WRITE(numout,*) '      choose the albedo parameterization                  nn_ice_alb = ', nn_ice_alb 
     270         WRITE(numout,*) '      albedo of bare puddled ice                          rn_albice  = ', rn_albice 
    226271      ENDIF 
    227272      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

    r5602 r7256  
    3232   PUBLIC   fld_map    ! routine called by tides_init 
    3333   PUBLIC   fld_read, fld_fill   ! called by sbc... modules 
     34   PUBLIC   fld_clopn 
    3435 
    3536   TYPE, PUBLIC ::   FLD_N      !: Namelist field informations 
    … …  
    815816         imonth = kmonth 
    816817         iday = kday 
     818         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
     819            isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 )   
     820            llprevmth  = isec_week > nsec_month             ! longer time since beginning of the week than the month 
     821            llprevyr   = llprevmth .AND. nmonth == 1 
     822            iyear  = nyear  - COUNT((/llprevyr /)) 
     823            imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) 
     824            iday   = nday   + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) 
     825         ENDIF 
    817826      ELSE                                                  ! use current day values 
    818827         IF ( sdjf%cltype(1:4) == 'week' ) THEN             ! find the day of the beginning of the week 
    … …  
    12811290      CHARACTER(LEN=*)          , INTENT(in   ) ::   lsmfile ! land sea mask file name 
    12821291      !!  
    1283       REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta,zfieldo                  ! temporary array of values on input grid 
     1292      REAL(wp),DIMENSION(:,:,:),ALLOCATABLE     ::   ztmp_fly_dta                          ! temporary array of values on input grid 
    12841293      INTEGER, DIMENSION(3)                     ::   rec1,recn                             ! temporary arrays for start and length 
    12851294      INTEGER, DIMENSION(3)                     ::   rec1_lsm,recn_lsm                     ! temporary arrays for start and length in case of seaoverland 
    … …  
    13471356 
    13481357 
    1349          itmpi=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),1) 
    1350          itmpj=SIZE(ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:),2) 
     1358         itmpi=jpi2_lsm-jpi1_lsm+1 
     1359         itmpj=jpj2_lsm-jpj1_lsm+1 
    13511360         itmpz=kk 
    13521361         ALLOCATE(ztmp_fly_dta(itmpi,itmpj,itmpz)) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5602 r7256  
    8080   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
    8181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2] 
     83   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    8485#endif 
    … …  
    144145#endif 
    145146#if defined key_lim3 
    146          &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
    147          &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
    148          &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
     147         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
     148         &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
     149         &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
    149150#endif 
    150151         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5602 r7256  
    684684      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    685685 
     686      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     687      DO jl = 1, jpl 
     688         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     689                                   ! but then qemp_ice should also include sublimation  
     690      END DO 
     691 
    686692      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    687693#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6772 r7256  
    4444   USE sbc_ice         ! Surface boundary condition: ice fields 
    4545   USE lib_fortran     ! to use key_nosignedzero 
    46    USE sbcapr 
    4746#if defined key_lim3 
    4847   USE ice, ONLY       : u_ice, v_ice, jpl, pfrld, a_i_b 
    4948   USE limthd_dh       ! for CALL lim_thd_snwblow 
    5049#elif defined key_lim2 
    51    USE ice_2, ONLY     : u_ice, v_ice, pfrld 
     50   USE ice_2, ONLY     : u_ice, v_ice 
    5251   USE par_ice_2 
    5352#endif 
    … …  
    8483   REAL(wp), PARAMETER ::   Cice =    1.4e-3      ! iovi 1.63e-3     ! transfer coefficient over ice 
    8584   REAL(wp), PARAMETER ::   albo =    0.066       ! ocean albedo assumed to be constant 
    86    REAL(wp), PARAMETER ::   rgas =  287.1         ! gas const. dry air (J/kg/K) 
    87    REAL(wp), PARAMETER ::   rvap =  461.51        ! gas const. vapour  (J/kg/K) 
    8885 
    8986   !                                  !!* Namelist namsbc_core : CORE bulk parameters 
    … …  
    9491   REAL(wp) ::   rn_zqt      ! z(q,t) : height of humidity and temperature measurements 
    9592   REAL(wp) ::   rn_zu       ! z(u)   : height of wind measurements 
    96    ! 
    97    LOGICAL  ::   ln_tair_celsius  !: logical flag for Read Tair: Tair in NEMO is Kelvin 
    98    LOGICAL  ::   ln_humi_rel      !: logical flag for Read relative humidity (T) or specific humidity (F) 
    99    LOGICAL  ::   ln_cohum_arc     !: logical flag for Correction of Humidity in the Arctic Ocean 
    100    LOGICAL  ::   ln_cotair_arc    !: logical flag for Correction of Air Temperature in the Arctic Ocean 
    101    LOGICAL  ::   ln_corad_antar   !: logical flag for Correction of radiatives fluxes in the Southern Ocean 
    102  
    10393 
    10494   !! * Substitutions 
    … …  
    153143      INTEGER  ::   ios      ! Local integer output status for namelist read 
    154144      ! 
    155       INTEGER  ::   ji,jj 
    156       REAL(wp) ::   zzlat, zzlat1, zzlat2, zfm, zfrld 
    157       REAL(wp) ::   zmin,zmax 
    158       REAL(wp), DIMENSION(:,:), POINTER :: xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair 
    159       REAL(wp), DIMENSION(:,:), POINTER :: zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr 
    160       
    161145      CHARACTER(len=100) ::  cn_dir   !   Root directory for location of core files 
    162146      TYPE(FLD_N), DIMENSION(jpfld) ::   slf_i     ! array of namelist informations on the fields to read 
    … …  
    167151         &                  sn_wndi, sn_wndj, sn_humi  , sn_qsr ,           & 
    168152         &                  sn_qlw , sn_tair, sn_prec  , sn_snow,           & 
    169          &                  sn_tdif, rn_zqt,  rn_zu , ln_tair_celsius,   & 
    170          &                  ln_humi_rel  , ln_cohum_arc,      & 
    171          &                  ln_cotair_arc, ln_corad_antar 
    172  
    173       !!--------------------------------------------------------------------- 
    174       ! 
    175       CALL wrk_alloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
    176       CALL wrk_alloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
     153         &                  sn_tdif, rn_zqt,  rn_zu 
     154      !!--------------------------------------------------------------------- 
     155      ! 
    177156      !                                         ! ====================== ! 
    178157      IF( kt == nit000 ) THEN                   !  First call kt=nit000  ! 
    … …  
    215194         CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_core', 'flux formulation for ocean surface boundary condition', 'namsbc_core' ) 
    216195         ! 
    217          ! 
    218          IF(lwp) WRITE(numout,*) 'sbc_blk_core: jfld = ',jfld 
    219          IF( ln_cohum_arc   ) CALL ctl_warn( 'sbc_blk_core: correction of humidity in arctic' ) 
    220          IF( ln_cotair_arc  ) CALL ctl_warn( 'sbc_blk_core: correction of air temperature in arctic' ) 
    221          IF( ln_corad_antar ) CALL ctl_warn( 'sbc_blk_core: correction of short radiation in antartic' ) 
    222          IF( ln_humi_rel    ) CALL ctl_warn( 'sbc_blk_core: use relative humidity instead of specific humidity') 
    223          IF( ln_tair_celsius) CALL ctl_warn( 'sbc_blk_core: Tair is read in Celsius') 
    224          IF(lwp) WRITE(numout,*) 'sbc_blk_core: rn_pfac = ',rn_pfac 
    225          ! 
    226196         sfx(:,:) = 0._wp                          ! salt flux; zero unless ice is present (computed in limsbc(_2).F90) 
    227197         ! 
    … …  
    229199 
    230200      CALL fld_read( kt, nn_fsbc, sf )             ! input fields provided at the current time-step 
    231  
    232       !========================================= 
    233       !  ONLINE CORRECTIONS 
    234       !========================================= 
    235       ! 
    236       ! Correction of Tair 
    237       ! 
    238       IF( ln_tair_celsius .AND. MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    239          sf(jp_tair)%fnow = sf(jp_tair)%fnow + 273.15_wp  ! Conversion of the Temperature °C --> Kelvin 
    240       ENDIF 
    241       ! 
    242       ! Correction of SW and LW in the Southern Ocean 
    243       ! 
    244       IF( ln_corad_antar .AND. .NOT. sf(jp_qsr)%ln_tint .AND. MOD( kt-1, 86400/INT(rdt) ) == 0 ) THEN 
    245          z_qsr(:,:) = 0.8 * sf(jp_qsr)%fnow(:,:,1) 
    246          xyt(:,:) = 0.e0 ; zzlat1 = -65. ; zzlat2 = -60. 
    247          DO jj = 1, jpj 
    248             DO ji = 1, jpi 
    249                zzlat = gphit(ji,jj) 
    250                IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 ) THEN 
    251                   xyt(ji,jj) = (zzlat2-zzlat)/(zzlat2-zzlat1) 
    252                ELSE IF ( zzlat < zzlat1 ) THEN 
    253                   xyt(ji,jj) = 1 
    254                ENDIF 
    255             END DO 
    256          END DO 
    257          IF(lwp) WRITE(numout,*) 'Correc ln_corad_antar' 
    258          z_qsr1(:,:) = z_qsr(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_qsr)%fnow(:,:,1) 
    259          sf(jp_qsr)%fnow(:,:,1) = z_qsr1(:,:) 
    260       ENDIF 
    261  
    262       IF( MOD( kt-1, nn_fsbc ) == 0 )THEN 
    263          ! 
    264          IF ( nmonth >= 5 .AND. nmonth <= 9 ) THEN 
    265             ! 
    266             ! Correction of Humidity in the Arctic Ocean 
    267             ! 
    268             IF( ln_cohum_arc ) THEN 
    269                z_hum(:,:) = 0.85 * sf(jp_humi)%fnow(:,:,1) 
    270                xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
    271                DO jj = 1, jpj 
    272                   DO ji = 1, jpi 
    273                      zzlat = gphit(ji,jj) 
    274 #if defined key_lim2 ||  defined key_lim3  
    275                      IF ( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld = 0 ; ENDIF 
    276 #endif 
    277                      IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
    278                         xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
    279                      ELSE IF ( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
    280                         xyt(ji,jj) = 1._wp 
    281                      ENDIF 
    282                   ENDDO 
    283                ENDDO 
    284                IF(lwp) WRITE(numout,*) 'Correc ln_cohum_arc' 
    285                sf(jp_humi)%fnow(:,:,1) = z_hum(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_humi)%fnow(:,:,1) 
    286             ENDIF 
    287             ! 
    288             ! Correction of Air Temperature in the Arctic Ocean 
    289             ! 
    290             IF( ln_cotair_arc ) THEN 
    291                z_tair(:,:) = sf(jp_tair)%fnow(:,:,1) - 2.0 
    292                xyt(:,:) = 0.e0 ; zzlat1 = 78. ; zzlat2 = 82. 
    293                DO jj = 1, jpj 
    294                   DO ji = 1, jpi 
    295                      zzlat = gphit(ji,jj) 
    296 #if defined key_lim2 ||  defined key_lim3  
    297                      IF( ALLOCATED(pfrld) ) THEN ; zfrld = pfrld(ji,jj) ; ELSE ; zfrld=0 ; ENDIF 
    298 #endif 
    299                      IF( zzlat >= zzlat1 .AND. zzlat <= zzlat2 .AND. zfrld < 0.85 ) THEN 
    300                         xyt(ji,jj) = ( zzlat - zzlat1 ) / ( zzlat2 - zzlat1 ) 
    301                      ELSE IF( zzlat > zzlat2 .AND. zfrld < 0.85 ) THEN 
    302                         xyt(ji,jj) = 1._wp 
    303                      ENDIF 
    304                   END DO 
    305                ENDDO 
    306                IF(lwp) WRITE(numout,*) 'Correc ln_cotair_arc' 
    307                sf(jp_tair)%fnow(:,:,1) = z_tair(:,:) * xyt(:,:) + ( 1.0 - xyt(:,:) ) * sf(jp_tair)%fnow(:,:,1) 
    308             ENDIF 
    309             ! 
    310          ENDIF ! 5 <= nmonth <= 9 
    311  
    312          ! 
    313       ENDIF ! IF MOD( kt-1, nn_fsbc ) 
    314  
    315       DO jj=1,jpj 
    316          DO ji=1,jpi 
    317             sf(jp_humi)%fnow(ji,jj,1) = MAX( MIN( sf(jp_humi)%fnow(ji,jj,1) ,1.0 ) , 0.0 ) 
    318             sf(jp_prec)%fnow(ji,jj,1) = MAX(      sf(jp_prec)%fnow(ji,jj,1) ,0.0 ) 
    319             sf(jp_qsr )%fnow(ji,jj,1) = MAX(      sf(jp_qsr )%fnow(ji,jj,1) ,0.0 ) 
    320             sf(jp_qlw )%fnow(ji,jj,1) = MAX(      sf(jp_qlw )%fnow(ji,jj,1) ,0.0 ) 
    321          ENDDO 
    322       END DO 
    323  
    324       ! 
    325       !========================================= 
    326       ! END OF ONLINE CORRECTIONS 
    327       !========================================= 
    328       ! 
    329201 
    330202      !                                            ! compute the surface ocean fluxes using CORE bulk formulea 
    … …  
    334206      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN 
    335207         qlw_ice(:,:,1)   = sf(jp_qlw)%fnow(:,:,1)  
    336          qsr_ice(:,:,1)   = sf(jp_qsr)%fnow(:,:,1) 
     208         IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) 
     209         ELSE                ; qsr_ice(:,:,1) =          sf(jp_qsr)%fnow(:,:,1) 
     210         ENDIF 
    337211         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)          
    338212         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1) 
    … …  
    343217      ENDIF 
    344218#endif 
    345       ! 
    346       CALL wrk_dealloc( jpi,jpj, xyt,z_qsr,z_qlw,z_qsr1,z_qlw1, z_hum, z_tair ) 
    347       CALL wrk_dealloc( jpi,jpj, zqsr_lr, zqsr_hr, zqlw_lr, zqlw_hr ) 
    348219      ! 
    349220   END SUBROUTINE sbc_blk_core 
    … …  
    388259      REAL(wp), DIMENSION(:,:), POINTER ::   zt_zu             ! air temperature at wind speed height 
    389260      REAL(wp), DIMENSION(:,:), POINTER ::   zq_zu             ! air spec. hum.  at wind speed height 
    390       REAL(wp), DIMENSION(:,:), POINTER ::   zqatm , zpatm     ! specific humidity and mean sea level pressure (Pa) 
    391       REAL(wp) :: vt, vp, vq, zqa, zq0, zq1, zq2, zee 
    392261      !!--------------------------------------------------------------------- 
    393262      ! 
    … …  
    395264      ! 
    396265      CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    397       CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ,zqatm, zpatm ) 
     266      CALL wrk_alloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    398267      ! 
    399268      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    447316      ! ... specific humidity at SST and IST 
    448317      zqsatw(:,:) = zcoef_qsatw * EXP( -5107.4 / zst(:,:) ) 
    449       ! 
    450       IF ( ln_humi_rel ) THEN 
    451          zq0    = rvap / rgas - 1.0 
    452          zq1    = rgas / rvap 
    453          zq2    = 1.0 - zq1 
    454          zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant  here) 
    455          IF ( ln_apr_dyn ) zpatm(:,:) = apr(:,:) 
    456          DO jj = 1 , jpj 
    457             DO ji = 1 , jpi 
    458                vt  = sf(jp_tair)%fnow(ji,jj,1) - rt0  ! air temperature (Celsius) 
    459                vp  = zpatm(ji,jj) / 100.              ! mean sea level pressure (mb or hPa) 
    460                vq  = sf(jp_humi)%fnow(ji,jj,1)        ! relative humidity (fraction of 1) 
    461                ! Convert RH at the air/sea interface in specific humidity (kg/kg) 
    462                ! Teten's formula for qsat (mb) 
    463                zqa = ( 1.0007 + 3.46e-6 * vp) * 6.1121 * EXP( 17.502 * vt / ( 240.97+vt ) ) 
    464                zee = zqa * vq                         ! vapour partial pressure (mb) 
    465                vq  = zq1 * zee / ( vp - zq2 * zee )   ! specific humidity (kg/kg) 
    466                zqatm(ji,jj) = vq 
    467             ENDDO 
    468          ENDDO 
    469       ELSE 
    470          zqatm(:,:)=sf(jp_humi)%fnow(:,:,1) 
    471       ENDIF 
    472       ! 
     318 
    473319      ! ... NCAR Bulk formulae, computation of Cd, Ch, Ce at T-point : 
    474       CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, zqatm, wndm,   & 
     320      CALL turb_core_2z( rn_zqt, rn_zu, zst, sf(jp_tair)%fnow, zqsatw, sf(jp_humi)%fnow, wndm,   & 
    475321         &               Cd, Ch, Ce, zt_zu, zq_zu ) 
    476322     
    … …  
    510356      IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN 
    511357         !! q_air and t_air are (or "are almost") given at 10m (wind reference height) 
    512          !zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
    513           zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - zqatm(:,:)              )*wndm(:,:) ) ! Evaporation 
     358         zevap(:,:) = rn_efac*MAX( 0._wp,     rhoa*Ce(:,:)*( zqsatw(:,:) - sf(jp_humi)%fnow(:,:,1) )*wndm(:,:) ) ! Evaporation 
    514359         zqsb (:,:) =                     cpa*rhoa*Ch(:,:)*( zst   (:,:) - sf(jp_tair)%fnow(:,:,1) )*wndm(:,:)   ! Sensible Heat 
    515360      ELSE 
    … …  
    560405         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
    561406         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
     407         tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
     408         sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
     409         CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
     410         CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
    562411      ENDIF 
    563412      ! 
    … …  
    571420      ! 
    572421      CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j, zqsatw, zqlw, zqsb, zqla, zevap ) 
    573       CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu, zqatm, zpatm ) 
     422      CALL wrk_dealloc( jpi,jpj, Cd, Ch, Ce, zst, zt_zu, zq_zu ) 
    574423      ! 
    575424      IF( nn_timing == 1 )  CALL timing_stop('blk_oce_core') 
    … …  
    594443      REAL(wp) ::             zwndi_t , zwndj_t               ! relative wind components at T-point 
    595444      !!--------------------------------------------------------------------- 
    596  
     445      ! 
    597446      IF( nn_timing == 1 )  CALL timing_start('blk_ice_core_tau') 
    598447      ! 
    … …  
    687536      REAL(wp) ::   zcoef_dqlw, zcoef_dqla, zcoef_dqsb 
    688537      REAL(wp) ::   zztmp, z1_lsub                               ! temporary variable 
    689       REAL(wp) ::   ztamr,zmt1,zmt2,zmt3,zev,zes 
    690538      !! 
    691539      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_qlw             ! long wave heat flux over ice 
    … …  
    694542      REAL(wp), DIMENSION(:,:,:), POINTER ::   z_dqsb            ! sensible  heat sensitivity over ice 
    695543      REAL(wp), DIMENSION(:,:)  , POINTER ::   zevap, zsnw       ! evaporation and snw distribution after wind blowing (LIM3) 
    696       REAL(wp), DIMENSION(:,:)  , POINTER ::   zqatm, zpatm , ztatm            ! specific humidity 
    697544      !!--------------------------------------------------------------------- 
    698545      ! 
    … …  
    700547      ! 
    701548      CALL wrk_alloc( jpi,jpj,jpl, z_qlw, z_qsb, z_dqlw, z_dqsb )  
    702       CALL wrk_alloc( jpi,jpj, zqatm, zpatm, ztatm ) 
    703   
    704      IF ( ln_humi_rel ) THEN 
    705          zpatm(:,:) = 100800.                   ! atmospheric pressure (assumed constant here) 
    706          IF (ln_apr_dyn) zpatm(:,:) = apr(:,:) 
    707          DO jj=1,jpj 
    708             DO ji=1,jpi 
    709                ztatm (ji,jj) = sf(jp_tair)%fnow(ji,jj,1)                   ! air temperature in Kelvins 
    710                ztamr = ztatm(ji,jj) - rtt                                  ! Saturation water vapour 
    711                zmt1  = SIGN( 17.269,  ztamr ) 
    712                zmt2  = SIGN( 21.875,  ztamr ) 
    713                zmt3  = SIGN( 28.200, -ztamr ) 
    714                zes   = 611.0 * EXP(  ABS( ztamr ) * MIN ( zmt1, zmt2 )   & 
    715                   &                / ( ztatm(ji,jj) - 35.86  + MAX( 0.e0, zmt3 ) )  ) 
    716                zev = sf(jp_humi)%fnow(ji,jj,1) * zes                       ! vapour pressure 
    717                zqatm(ji,jj) = 0.622 * zev / ( zpatm(ji,jj) - 0.378 * zev ) ! specific humidity 
    718             ENDDO 
    719          ENDDO 
    720       ELSE 
    721          zqatm(:,:) = sf(jp_humi)%fnow(:,:,1) 
    722       ENDIF 
    723549 
    724550      ! local scalars ( place there for vector optimisation purposes) 
    … …  
    754580               ! Latent Heat 
    755581               qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, rhoa * Ls  * Cice * wndm_ice(ji,jj)   &                            
    756                   &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - zqatm(ji,jj)  ) ) 
     582                  &                         * (  11637800. * EXP( -5897.8 / ptsu(ji,jj,jl) ) / rhoa - sf(jp_humi)%fnow(ji,jj,1)  ) ) 
    757583              ! Latent heat sensitivity for ice (Dqla/Dt) 
    758584               IF( qla_ice(ji,jj,jl) > 0._wp ) THEN 
    … …  
    788614      ! --- evaporation --- ! 
    789615      z1_lsub = 1._wp / Lsub 
    790       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    791       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    792       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     616      evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
     617      devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
     618      zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
    793619 
    794620      ! --- evaporation minus precipitation --- ! 
    … …  
    814640      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    815641 
     642      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     643      DO jl = 1, jpl 
     644         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
     645                                   ! But we do not have Tice => consider it at 0°C => evap=0  
     646      END DO 
     647 
    816648      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    817649#endif 
    … …  
    839671      IF( nn_timing == 1 )  CALL timing_stop('blk_ice_core_flx') 
    840672       
    841       CALL wrk_dealloc( jpi,jpj, zqatm, zpatm, ztatm ) 
    842673   END SUBROUTINE blk_ice_core_flx 
    843674#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r5602 r7256  
    10291029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    10301030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1031         un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10311032         CALL iom_put( 'ssu_m', ssu_m ) 
    10321033      ENDIF 
    … …  
    10341035         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    10351036         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
     1037         vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10361038         CALL iom_put( 'ssv_m', ssv_m ) 
    10371039      ENDIF 
    … …  
    13331335      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13341336      !! 
    1335       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1336       !!              ocean-ice system. 
     1337      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13371338      !! 
    13381339      !! ** Method  :   transform the fields received from the atmosphere into 
    13391340      !!             surface heat and fresh water boundary condition for the  
    13401341      !!             ice-ocean system. The following fields are provided: 
    1341       !!              * total non solar, solar and freshwater fluxes (qns_tot,  
     1342      !!               * total non solar, solar and freshwater fluxes (qns_tot,  
    13421343      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux) 
    13431344      !!             NB: emp_tot include runoffs and calving. 
    1344       !!              * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
     1345      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
    13451346      !!             emp_ice = sublimation - solid precipitation as liquid 
    13461347      !!             precipitation are re-routed directly to the ocean and  
    1347       !!             runoffs and calving directly enter the ocean. 
    1348       !!              * solid precipitation (sprecip), used to add to qns_tot  
     1348      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90) 
     1349      !!               * solid precipitation (sprecip), used to add to qns_tot  
    13491350      !!             the heat lost associated to melting solid precipitation 
    13501351      !!             over the ocean fraction. 
    1351       !!       ===>> CAUTION here this changes the net heat flux received from 
    1352       !!             the atmosphere 
    1353       !! 
    1354       !!                  - the fluxes have been separated from the stress as 
    1355       !!                 (a) they are updated at each ice time step compare to 
    1356       !!                 an update at each coupled time step for the stress, and 
    1357       !!                 (b) the conservative computation of the fluxes over the 
    1358       !!                 sea-ice area requires the knowledge of the ice fraction 
    1359       !!                 after the ice advection and before the ice thermodynamics, 
    1360       !!                 so that the stress is updated before the ice dynamics 
    1361       !!                 while the fluxes are updated after it. 
     1352      !!               * heat content of rain, snow and evap can also be provided, 
     1353      !!             otherwise heat flux associated with these mass flux are 
     1354      !!             guessed (qemp_oce, qemp_ice) 
     1355      !! 
     1356      !!             - the fluxes have been separated from the stress as 
     1357      !!               (a) they are updated at each ice time step compare to 
     1358      !!               an update at each coupled time step for the stress, and 
     1359      !!               (b) the conservative computation of the fluxes over the 
     1360      !!               sea-ice area requires the knowledge of the ice fraction 
     1361      !!               after the ice advection and before the ice thermodynamics, 
     1362      !!               so that the stress is updated before the ice dynamics 
     1363      !!               while the fluxes are updated after it. 
     1364      !! 
     1365      !! ** Details 
     1366      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1367      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1368      !! 
     1369      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1370      !! 
     1371      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1372      !!                                                                      river runoff (rnf) is provided but not included here 
    13621373      !! 
    13631374      !! ** Action  :   update at each nf_ice time step: 
    13641375      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13651376      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice 
    1366       !!                   emp_tot            total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 
    1367       !!                   emp_ice            ice sublimation - solid precipitation over the ice 
    1368       !!                   dqns_ice           d(non-solar heat flux)/d(Temperature) over the ice 
    1369       !!                   sprecip             solid precipitation over the ocean   
     1377      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1378      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1379      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1380      !!                   sprecip           solid precipitation over the ocean   
    13701381      !!---------------------------------------------------------------------- 
    13711382      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
    … …  
    13761387      ! 
    13771388      INTEGER ::   jl         ! dummy loop index 
    1378       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
    1379       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
    1380       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
    1381       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
     1389      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1390      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
     1391      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1392      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13821393      !!---------------------------------------------------------------------- 
    13831394      ! 
    13841395      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13851396      ! 
    1386       CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1387       CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1397      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1398      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1399      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1400      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13881401 
    13891402      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    13921405      ! 
    13931406      !                                                      ! ========================= ! 
    1394       !                                                      !    freshwater budget      !   (emp) 
     1407      !                                                      !    freshwater budget      !   (emp_tot) 
    13951408      !                                                      ! ========================= ! 
    13961409      ! 
    1397       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1398       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1399       !                                                           ! solid Precipitation                     (sprecip) 
    1400       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1410      !                                                           ! solid Precipitation                                (sprecip) 
     1411      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1412      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1413      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    14011414      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    1402       CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1403          zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    1404          ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    1405          zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1406          zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    1407             CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
     1415      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
     1416         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1417         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
     1418         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1419         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1420               CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
    14081421         IF( iom_use('hflx_rain_cea') )   & 
    1409             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from liq. precip.  
    1410          IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
    1411             ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1422            &  CALL iom_put( 'hflx_rain_cea',   frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:)                                            )  ! heat flux from liq. precip.  
    14121423         IF( iom_use('evap_ao_cea'  ) )   & 
    1413             CALL iom_put( 'evap_ao_cea'  , ztmp                   )   ! ice-free oce evap (cell average) 
     1424            &  CALL iom_put( 'evap_ao_cea'  ,   frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)                )  ! ice-free oce evap (cell average) 
    14141425         IF( iom_use('hflx_evap_cea') )   & 
    1415             CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    1416       CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
     1426            &  CALL iom_put( 'hflx_evap_cea', ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) * zcptn(:,:) )  ! heat flux from from evap (cell average) 
     1427      CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14171428         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1418          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1429         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14191430         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14201431         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14211432      END SELECT 
    14221433 
    1423       IF( iom_use('subl_ai_cea') )   & 
    1424          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1425       !    
    1426       !                                                           ! runoffs and calving (put in emp_tot) 
     1434#if defined key_lim3 
     1435      ! zsnw = snow fraction over ice after wind blowing 
     1436      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1437       
     1438      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1439      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1440      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1441 
     1442      ! --- evaporation over ocean (used later for qemp) --- ! 
     1443      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1444 
     1445      ! --- evaporation over ice (kg/m2/s) --- ! 
     1446      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1447      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1448      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1449      zdevap_ice(:,:) = 0._wp 
     1450       
     1451      ! --- runoffs (included in emp later on) --- ! 
     1452      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1453 
     1454      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1455      IF( srcv(jpr_cal)%laction ) THEN  
     1456         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1457         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1458         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1459      ENDIF 
     1460 
     1461      IF( ln_mixcpl ) THEN 
     1462         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1463         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1464         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1465         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1466         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1467         DO jl=1,jpl 
     1468            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
     1469            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
     1470         ENDDO 
     1471      ELSE 
     1472         emp_tot(:,:) =         zemp_tot(:,:) 
     1473         emp_ice(:,:) =         zemp_ice(:,:) 
     1474         emp_oce(:,:) =         zemp_oce(:,:)      
     1475         sprecip(:,:) =         zsprecip(:,:) 
     1476         tprecip(:,:) =         ztprecip(:,:) 
     1477         DO jl=1,jpl 
     1478            evap_ice (:,:,jl) = zevap_ice (:,:) 
     1479            devap_ice(:,:,jl) = zdevap_ice(:,:) 
     1480         ENDDO 
     1481      ENDIF 
     1482 
     1483      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1484                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1485      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1486      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
     1487#else 
     1488      ! runoffs and calving (put in emp_tot) 
    14271489      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    14281490      IF( srcv(jpr_cal)%laction ) THEN  
    … …  
    14431505      ENDIF 
    14441506 
    1445          CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
    1446       IF( iom_use('snow_ao_cea') )   & 
    1447          CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:)             )   ! Snow        over ice-free ocean  (cell average) 
    1448       IF( iom_use('snow_ai_cea') )   & 
    1449          CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
     1507      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1508                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1509      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1510      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
     1511#endif 
    14501512 
    14511513      !                                                      ! ========================= ! 
    14521514      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    14531515      !                                                      ! ========================= ! 
    1454       CASE( 'oce only' )                                     ! the required field is directly provided 
    1455          zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    1456       CASE( 'conservative' )                                      ! the required fields are directly provided 
    1457          zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1516      CASE( 'oce only' )         ! the required field is directly provided 
     1517         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1518      CASE( 'conservative' )     ! the required fields are directly provided 
     1519         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14581520         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14591521            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    14601522         ELSE 
    1461             ! Set all category values equal for the moment 
    14621523            DO jl=1,jpl 
    1463                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1524               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    14641525            ENDDO 
    14651526         ENDIF 
    1466       CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1467          zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1527      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1528         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    14681529         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14691530            DO jl=1,jpl 
    … …  
    14721533            ENDDO 
    14731534         ELSE 
    1474             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1535            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    14751536            DO jl=1,jpl 
    14761537               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    … …  
    14781539            ENDDO 
    14791540         ENDIF 
    1480       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1541      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    14811542! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    14821543         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14831544         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    14841545            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1485             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1546            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    14861547      END SELECT 
    14871548!!gm 
    … …  
    14931554!! similar job should be done for snow and precipitation temperature 
    14941555      !                                      
    1495       IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    1496          ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1497          zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    1498          IF( iom_use('hflx_cal_cea') )   & 
    1499             CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    1500       ENDIF 
    1501  
    1502       ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
    1503       IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    1504  
    1505 #if defined key_lim3 
    1506       CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
    1507  
    1508       ! --- evaporation --- ! 
    1509       ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
    1510       ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
    1511       !                 but it is incoherent WITH the ice model   
    1512       DO jl=1,jpl 
    1513          evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
    1514       ENDDO 
    1515       zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
    1516  
    1517       ! --- evaporation minus precipitation --- ! 
    1518       emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
    1519  
     1556      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1557         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1558                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1559         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1560      ENDIF 
     1561 
     1562#if defined key_lim3       
    15201563      ! --- non solar flux over ocean --- ! 
    15211564      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    15231566      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15241567 
    1525       ! --- heat flux associated with emp --- ! 
    1526       zsnw(:,:) = 0._wp 
    1527       CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
    1528       zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    1529          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    1530          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
    1531       qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    1532          &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1533  
    1534       ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1568      ! --- heat flux associated with emp (W/m2) --- ! 
     1569      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1570         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1571         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1572!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1573!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1574      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1575                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
     1576       
     1577      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15351578      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15361579 
    1537       ! --- total non solar flux --- ! 
    1538       zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1580      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     1581      DO jl = 1, jpl 
     1582         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
     1583      END DO 
     1584 
     1585      ! --- total non solar flux (including evap/precip) --- ! 
     1586      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
    15391587 
    15401588      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15431591         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15441592         DO jl=1,jpl 
    1545             qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1593            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
     1594            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
    15461595         ENDDO 
    15471596         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15481597         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1549 !!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1598         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
    15501599      ELSE 
    15511600         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    15521601         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    15531602         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
    1554          qprec_ice(:,:)   = zqprec_ice(:,:) 
    1555          qemp_oce (:,:)   = zqemp_oce (:,:) 
    1556       ENDIF 
    1557  
    1558       CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1603         qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
     1604         qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
     1605         qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
     1606         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
     1607      ENDIF 
     1608 
     1609      ! some more outputs 
     1610      IF( iom_use('hflx_snow_cea') )    CALL iom_put('hflx_snow_cea',   sprecip(:,:) * ( zcptn(:,:) - Lfus ) )                       ! heat flux from snow (cell average) 
     1611      IF( iom_use('hflx_rain_cea') )    CALL iom_put('hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )                 ! heat flux from rain (cell average) 
     1612      IF( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * (1._wp - zsnw(:,:)) ) ! heat flux from snow (cell average) 
     1613      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) )           ! heat flux from snow (cell average) 
     1614 
    15591615#else 
    1560  
    15611616      ! clem: this formulation is certainly wrong... but better than it was... 
    15621617      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    15631618         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    15641619         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1565          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1620         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    15661621 
    15671622     IF( ln_mixcpl ) THEN 
    … …  
    15751630         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    15761631      ENDIF 
    1577  
    15781632#endif 
    15791633 
    … …  
    16261680 
    16271681#if defined key_lim3 
    1628       CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16291682      ! --- solar flux over ocean --- ! 
    16301683      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16341687      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16351688      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
    1636  
    1637       CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16381689#endif 
    16391690 
    … …  
    16861737      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    16871738 
    1688       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1689       CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
     1739      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1740      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1741      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1742      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    16901743      ! 
    16911744      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17431796                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    17441797                  ELSEWHERE 
    1745                      ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
     1798                     ztmp3(:,:,1) = rt0 
    17461799                  END WHERE 
    17471800               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    … …  
    17741827      !                                                      ! ------------------------- ! 
    17751828      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1776          SELECT CASE( sn_snd_alb%cldes ) 
    1777          CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
    1778          CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1779          CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1829          SELECT CASE( sn_snd_alb%cldes ) 
     1830          CASE( 'ice' ) 
     1831             SELECT CASE( sn_snd_alb%clcat ) 
     1832             CASE( 'yes' )    
     1833                ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1834             CASE( 'no' ) 
     1835                WHERE( SUM( a_i, dim=3 ) /= 0. ) 
     1836                   ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 
     1837                ELSEWHERE 
     1838                   ztmp1(:,:) = albedo_oce_mix(:,:) 
     1839                END WHERE 
     1840             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 
     1841             END SELECT 
     1842          CASE( 'weighted ice' )   ; 
     1843             SELECT CASE( sn_snd_alb%clcat ) 
     1844             CASE( 'yes' )    
     1845                ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1846             CASE( 'no' ) 
     1847                WHERE( fr_i (:,:) > 0. ) 
     1848                   ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 
     1849                ELSEWHERE 
     1850                   ztmp1(:,:) = 0. 
     1851                END WHERE 
     1852             CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 
     1853             END SELECT 
     1854          CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
    17801855         END SELECT 
    1781          CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
    1782       ENDIF 
     1856 
     1857         SELECT CASE( sn_snd_alb%clcat ) 
     1858            CASE( 'yes' )    
     1859               CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode 
     1860            CASE( 'no'  )    
     1861               CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )  
     1862         END SELECT 
     1863      ENDIF 
     1864 
    17831865      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean 
    17841866         ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r5602 r7256  
    108108         ! 
    109109         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    110             z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
     110            z_fwf = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area   ! sum over the global domain 
    111111            zcoef = z_fwf * rcp 
    112112            emp(:,:) = emp(:,:) - z_fwf              * tmask(:,:,1) 
    … …  
    162162            zsurf_pos = glob_sum( e1e2t(:,:)*ztmsk_pos(:,:) ) 
    163163            !                                                  ! fwf global mean (excluding ocean to ice/snow exchanges)  
    164             z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
     164            z_fwf     = glob_sum( e1e2t(:,:) * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) - snwice_fmass(:,:) ) ) / area 
    165165            !             
    166166            IF( z_fwf < 0._wp ) THEN         ! spread out over >0 erp area to increase evaporation 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

    r5602 r7256  
    103103                                 ! ( d rho / dt ) / ( d rho / ds )      ( s = 34, t = -1.8 ) 
    104104          
    105          fr_i(:,:) = eos_fzp( sss_m ) * tmask(:,:,1)      ! sea surface freezing temperature [Celcius] 
     105         CALL eos_fzp( sss_m(:,:), fr_i(:,:) )       ! sea surface freezing temperature [Celcius] 
     106         fr_i(:,:) = fr_i(:,:) * tmask(:,:,1) 
    106107 
    107108         IF( ln_cpl )   a_i(:,:,1) = fr_i(:,:)          

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r5602 r7256  
    110110      INTEGER  ::   jl                 ! dummy loop index 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    112       REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    113112      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    114113      !!---------------------------------------------------------------------- 
    … …  
    126125          
    127126         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    128          t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
    129           
     127         CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 
     128         t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
     129           
    130130         ! Mask sea ice surface temperature (set to rt0 over land) 
    131131         DO jl = 1, jpl 
    … …  
    196196         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    197197         !---------------------------------------------------------------------------------------- 
    198          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     198         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    199199         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    200200 
    … …  
    202202         CASE( jp_clio )                                       ! CLIO bulk formulation 
    203203            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    204             ! (zalb_ice) is computed within the bulk routine 
    205             CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
    206             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    207             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     204            ! (alb_ice) is computed within the bulk routine 
     205                                 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 
     206            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     207            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    208208         CASE( jp_core )                                       ! CORE bulk formulation 
    209209            ! albedo depends on cloud fraction because of non-linear spectral effects 
    210             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    211             CALL blk_ice_core_flx( t_su, zalb_ice ) 
    212             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    213             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     210            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     211                                 CALL blk_ice_core_flx( t_su, alb_ice ) 
     212            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     213            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    214214         CASE ( jp_purecpl ) 
    215215            ! albedo depends on cloud fraction because of non-linear spectral effects 
    216             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    217                                  CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    218             ! clem: evap_ice is forced to 0 in coupled mode for now  
    219             !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
    220             evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
    221             IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     216            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     217                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     218            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    222219         END SELECT 
    223          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     220         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    224221 
    225222         !----------------------------! 
    … …  
    232229         CALL lim_sbc_flx( kt )                     ! Update surface ocean mass, heat and salt fluxes 
    233230         ! 
    234          IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
     231         IF(ln_limdiaout) CALL lim_diahsb( kt )     ! Diagnostics and outputs  
    235232         ! 
    236233         CALL lim_wri( 1 )                          ! Ice outputs  
    … …  
    264261      !!---------------------------------------------------------------------- 
    265262      INTEGER :: ierr 
     263      INTEGER :: ji, jj 
    266264      !!---------------------------------------------------------------------- 
    267265      IF(lwp) WRITE(numout,*) 
    … …  
    312310         numit = nit000 - 1 
    313311      ENDIF 
    314       CALL lim_var_agg(1) 
     312      CALL lim_var_agg(2) 
    315313      CALL lim_var_glo2eqv 
    316314      ! 
    317315      CALL lim_sbc_init                 ! ice surface boundary condition    
     316      ! 
     317      IF( ln_limdiaout) CALL lim_diahsb_init  ! initialization for diags 
    318318      ! 
    319319      fr_i(:,:)     = at_i(:,:)         ! initialisation of sea-ice fraction 
    320320      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
     321      ! 
     322      DO jj = 1, jpj 
     323         DO ji = 1, jpi 
     324            IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
     325            ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
     326            ENDIF 
     327        ENDDO 
     328      ENDDO  
    321329      ! 
    322330      nstart = numit  + nn_fsbc       
    … …  
    342350      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    343351      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
    344          &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     352         &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    345353      !!------------------------------------------------------------------- 
    346354      !                     
    … …  
    363371         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    364372         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    365          WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     373         WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
     374         WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
    366375         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    367376         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    578587      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    579588      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    580       sfx_res(:,:) = 0._wp 
     589      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
    581590       
    582591      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    594603      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    595604      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    596       hfx_err_dif(:,:) = 0._wp   ; 
    597  
     605      hfx_err_dif(:,:) = 0._wp 
     606      wfx_err_sub(:,:) = 0._wp 
     607       
    598608      afx_tot(:,:) = 0._wp   ; 
    599609      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

    r5602 r7256  
    150150 
    151151         ! ... masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    152          tfu(:,:) = eos_fzp( sss_m ) +  rt0  
     152         CALL eos_fzp( sss_m(:,:), tfu(:,:) ) 
     153         tfu(:,:) = tfu(:,:) + rt0 
    153154 
    154155         zsist (:,:,1) = sist (:,:) + rt0 * ( 1. - tmask(:,:,1) ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r5602 r7256  
    5353   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5454   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
    55 #if defined key_agrif 
    56    ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals 
    57    REAL(wp),    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    58                                                                                           !: (first wet level and last level include in the tbl) 
    59 #else 
    6055   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
    61 #endif 
    6256 
    6357 
    … …  
    9286    REAL(wp)                     ::   rmin 
    9387    REAL(wp)                     ::   zhk 
    94     CHARACTER(len=256)           ::   cfisf, cvarzisf, cvarhisf   ! name for isf file 
     88    REAL(wp)                     ::   zt_frz, zpress 
     89    CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
    9590    CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    9691    CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    … …  
    176171              DO jj = 1, jpj 
    177172                  jk = 2 
    178                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     173                  DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    179174                  misfkt(ji,jj) = jk-1 
    180175               END DO 
    … …  
    194189         END IF 
    195190          
     191         ! save initial top boundary layer thickness          
    196192         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
     193 
     194      END IF 
     195 
     196      !                                            ! ---------------------------------------- ! 
     197      IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
     198         !                                         ! ---------------------------------------- ! 
     199         fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
     200         risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
     201         ! 
     202      ENDIF 
     203 
     204      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    197205 
    198206         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    … …  
    205213 
    206214               ! determine the deepest level influenced by the boundary layer 
    207                ! test on tmask useless ????? 
    208215               DO jk = ikt, mbkt(ji,jj) 
    209216                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    … …  
    217224            END DO 
    218225         END DO 
    219           
    220       END IF 
    221  
    222       !                                            ! ---------------------------------------- ! 
    223       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    224          !                                         ! ---------------------------------------- ! 
    225          fwfisf_b  (:,:  ) = fwfisf  (:,:  )               ! Swap the ocean forcing fields except at nit000 
    226          risf_tsc_b(:,:,:) = risf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    227          ! 
    228       ENDIF 
    229  
    230       IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    231  
    232226 
    233227         ! compute salf and heat flux 
    … …  
    270264         END IF 
    271265         ! compute tsc due to isf 
    272          ! WARNING water add at temp = 0C, correction term is added in trasbc, maybe better here but need a 3D variable). 
    273          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp ! 
     266         ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
     267!         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     268         zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
     269         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
    274270          
    275271         ! salt effect already take into account in vertical advection 
    276272         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    277            
     273 
     274         ! output 
     275         IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
     276         IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
     277 
     278         ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
     279         fwfisf(:,:) = rdivisf * fwfisf(:,:)          
     280  
    278281         ! lbclnk 
    279282         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    … …  
    295298         ENDIF 
    296299         !  
    297          ! output 
    298          CALL iom_put('qisf'  , qisf) 
    299          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    300300      END IF 
    301301   
    … …  
    370370             ! Calculate freezing temperature 
    371371                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    372                 zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
     372                CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
    373373                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    374374             ENDDO 
    … …  
    452452      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    453453! Calculate freezing temperature 
    454       zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
     454      CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
    455455 
    456456       
    … …  
    472472 
    473473                     nit = nit + 1 
    474                      IF (nit .GE. 100) THEN 
    475                         !WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b,zgammat, rn_gammat0, rn_tfri2, nn_gammablk, ji,jj 
    476                         !WRITE(numout,*) "sbcisf : too many iteration ... ", (zhtflx - zhtflx_b)/zhtflx 
    477                         CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    478                      END IF 
     474                     IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     475 
    479476! save gammat and compute zhtflx_b 
    480477                     zgammat2d(ji,jj)=zgammat 
    … …  
    794791               ! test on tmask useless ????? 
    795792               DO jk = ikt, mbkt(ji,jj) 
    796 !                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     793                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    797794               END DO 
    798795               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r5602 r7256  
    179179 
    180180      !                          ! Checks: 
    181       IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
     181      IF( nn_isf .EQ. 0 ) THEN                      ! variable initialisation if no ice shelf  
    182182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    183          fwfisf  (:,:) = 0.0_wp 
    184          fwfisf_b(:,:) = 0.0_wp 
     183         fwfisf  (:,:)   = 0.0_wp ; fwfisf_b  (:,:)   = 0.0_wp 
     184         risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 
     185         rdivisf       = 0.0_wp 
    185186      END IF 
    186187      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    … …  
    339340         emp_b(:,:) = emp(:,:) 
    340341         sfx_b(:,:) = sfx(:,:) 
     342         IF ( ln_rnf ) THEN 
     343            rnf_b    (:,:  ) = rnf    (:,:  ) 
     344            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     345         ENDIF 
    341346      ENDIF 
    342347      !                                            ! ---------------------------------------- ! 
    … …  
    455460      !                                                ! ---------------------------------------- ! 
    456461      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    457          CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
     462         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
     463         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    458464         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    459465                                                                ! (includes virtual salt flux beneath ice  

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r5602 r7256  
    5252   REAL(wp)                   ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5353   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    54    REAL(wp)                  ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
    5555 
    5656   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    … …  
    109109      ! 
    110110      CALL wrk_alloc( jpi,jpj, ztfrz) 
    111  
    112       !                                            ! ---------------------------------------- ! 
    113       IF( kt /= nit000 ) THEN                      !          Swap of forcing fields          ! 
    114          !                                         ! ---------------------------------------- ! 
    115          rnf_b    (:,:  ) = rnf    (:,:  )               ! Swap the ocean forcing fields except at nit000 
    116          rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:)               ! where before fields are set at the end of the routine 
    117          ! 
    118       ENDIF 
    119  
     111      ! 
    120112      !                                            !-------------------! 
    121113      !                                            !   Update runoff   ! 
    … …  
    125117      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    126118      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
    127       ! 
    128       ! Runoff reduction only associated to the ORCA2_LIM configuration 
    129       ! when reading the NetCDF file runoff_1m_nomask.nc 
    130       IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
    131          WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
    132             sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
    133          END WHERE 
    134       ENDIF 
    135119      ! 
    136120      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

    r5602 r7256  
    3131CONTAINS 
    3232 
    33    SUBROUTINE upd_tide( kt, kit, kbaro, koffset ) 
     33   SUBROUTINE upd_tide( kt, kit, time_offset ) 
    3434      !!---------------------------------------------------------------------- 
    3535      !!                 ***  ROUTINE upd_tide  *** 
    … …  
    4242      !!----------------------------------------------------------------------       
    4343      INTEGER, INTENT(in)           ::   kt      ! ocean time-step index 
    44       INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T only) 
    45       INTEGER, INTENT(in), OPTIONAL ::   kbaro   ! number of sub-time-step           (lk_dynspg_ts=T only) 
    46       INTEGER, INTENT(in), OPTIONAL ::   koffset ! time offset in number  
    47                                                  ! of sub-time-steps                 (lk_dynspg_ts=T only) 
     44      INTEGER, INTENT(in), OPTIONAL ::   kit     ! external mode sub-time-step index (lk_dynspg_ts=T) 
     45      INTEGER, INTENT(in), OPTIONAL ::   time_offset ! time offset in number  
     46                                                     ! of internal steps             (lk_dynspg_ts=F) 
     47                                                     ! of external steps             (lk_dynspg_ts=T) 
    4848      ! 
    4949      INTEGER  ::   joffset      ! local integer 
    … …  
    5757      ! 
    5858      joffset = 0 
    59       IF( PRESENT( koffset ) )   joffset = koffset 
     59      IF( PRESENT( time_offset ) )   joffset = time_offset 
    6060      ! 
    61       IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   THEN 
    62          zt = zt + ( kit + 0.5_wp * ( joffset - 1 ) ) * rdt / REAL( kbaro, wp ) 
     61      IF( PRESENT( kit ) )   THEN 
     62         zt = zt + ( kit +  joffset - 1 ) * rdt / REAL( nn_baro, wp ) 
    6363      ELSE 
    6464         zt = zt + joffset * rdt 
    … …  
    7474      IF( ln_tide_ramp ) THEN         ! linear increase if asked 
    7575         zt = ( kt - nit000 ) * rdt 
    76          IF( PRESENT( kit ) .AND. PRESENT( kbaro ) )   zt = zt + kit * rdt / REAL( kbaro, wp ) 
     76         IF( PRESENT( kit ) )   zt = zt + ( kit + joffset -1) * rdt / REAL( nn_baro, wp ) 
    7777         zramp = MIN(  MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp  ) 
    7878         pot_astro(:,:) = zramp * pot_astro(:,:) 
    … …  
    8686  !!---------------------------------------------------------------------- 
    8787CONTAINS 
    88   SUBROUTINE upd_tide( kt, kit, kbaro, koffset )          ! Empty routine 
     88  SUBROUTINE upd_tide( kt, kit, time_offset )  ! Empty routine 
    8989    INTEGER, INTENT(in)           ::   kt      !  integer  arg, dummy routine 
    9090    INTEGER, INTENT(in), OPTIONAL ::   kit     !  optional arg, dummy routine 
    91     INTEGER, INTENT(in), OPTIONAL ::   kbaro   !  optional arg, dummy routine 
    92     INTEGER, INTENT(in), OPTIONAL ::   koffset !  optional arg, dummy routine 
     91    INTEGER, INTENT(in), OPTIONAL ::   time_offset !  optional arg, dummy routine 
    9392    WRITE(*,*) 'upd_tide: You should not have seen this print! error?', kt 
    9493  END SUBROUTINE upd_tide 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

    r4624 r7256  
    9292      IF( .NOT. lk_agrif .OR. .NOT. ln_rstart) THEN 
    9393         IF( sol_oce_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'solver_init : unable to allocate sol_oce arrays' ) 
     94         gcx (:,:) = 0.e0 
     95         gcxb(:,:) = 0.e0 
    9496      ENDIF 
    9597 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r5488 r7256  
    849849 
    850850 
    851    REAL(wp) FUNCTION sto_par_flt_fac( kpasses ) 
     851   FUNCTION sto_par_flt_fac( kpasses ) 
    852852      !!---------------------------------------------------------------------- 
    853853      !!                  ***  FUNCTION sto_par_flt_fac  *** 
    … …  
    858858      !!---------------------------------------------------------------------- 
    859859      INTEGER, INTENT(in) :: kpasses 
     860      REAL(wp) :: sto_par_flt_fac 
    860861      !! 
    861862      INTEGER :: jpasses, ji, jj, jflti, jfltj 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6101 r7256  
    2222   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
    2323   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
     24   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
    2425   !!---------------------------------------------------------------------- 
    2526 
    … …  
    991992 
    992993 
    993    FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
     994   SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
    994995      !!---------------------------------------------------------------------- 
    995996      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10051006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10061007      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1007       REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
     1008      REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
    10081009      ! 
    10091010      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    10171018         DO jj = 1, jpj 
    10181019            DO ji = 1, jpi 
    1019                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1020               zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp )           ! square root salinity 
    10201021               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10211022                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10381039         nstop = nstop + 1 
    10391040         ! 
    1040       END SELECT 
    1041       ! 
    1042    END FUNCTION eos_fzp_2d 
    1043  
    1044   FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
     1041      END SELECT       
     1042      ! 
     1043  END SUBROUTINE eos_fzp_2d 
     1044 
     1045  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    10451046      !!---------------------------------------------------------------------- 
    10461047      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10541055      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10551056      !!---------------------------------------------------------------------- 
    1056       REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
    1057       REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
    1058       REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
     1057      REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
     1058      REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
     1059      REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
    10591060      ! 
    10601061      REAL(wp) :: zs   ! local scalars 
    … …  
    10651066      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    10661067         ! 
    1067          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1068         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity 
    10681069         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10691070                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    … …  
    10861087      END SELECT 
    10871088      ! 
    1088    END FUNCTION eos_fzp_0d 
     1089   END SUBROUTINE eos_fzp_0d 
    10891090 
    10901091 
    … …  
    12551256            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12561257         ENDIF 
     1258      ENDIF 
     1259      ! 
     1260      ! Consistency check on ln_useCT and nn_eos 
     1261      IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 
     1262         CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 
     1263      ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 
     1264         CALL ctl_stop("ln_useCT should be set to False if using TEOS-80 or simplified equation of state (nn_eos=0 or nn_eos=1)") 
    12571265      ENDIF 
    12581266      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

    r5602 r7256  
    173173         END DO  
    174174      END DO  
    175       zfzp(:,:) = eos_fzp( tsn(:,:,1,jp_sal), zpres(:,:) ) 
     175      CALL eos_fzp( tsn(:,:,1,jp_sal), zfzp(:,:), zpres(:,:) ) 
    176176      DO jk = 1, jpk 
    177177         DO jj = 1, jpj 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

    r4990 r7256  
    212212      CHARACTER(len=3) ::   cdtype 
    213213      REAL, DIMENSION(:,:,:) ::   pun, pvn, pwn 
    214       WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
     214      WRITE(*,*) 'tra_adv_eiv: You should not have seen this print! error?', & 
     215          &  kt, cdtype, pun(1,1,1), pvn(1,1,1), pwn(1,1,1) 
    215216   END SUBROUTINE tra_adv_eiv 
    216217#endif 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r5602 r7256  
    173173            DO jj = 2, jpjm1 
    174174               DO ji = fs_2, fs_jpim1   ! vector opt. 
    175                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    176175                  ! total intermediate advective trends 
    177                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    178                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    179                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     176                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     177                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     178                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    180179                  ! update and guess with monotonic sheme 
    181                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra  * tmask(ji,jj,jk) 
    182                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     180                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     181                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    183182               END DO 
    184183            END DO 
    … …  
    326325      CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
    327326      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
    328       CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
     327      CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    329328      ! 
    330329      IF( kt == kit000 )  THEN 
    … …  
    410409            DO jj = 2, jpjm1 
    411410               DO ji = fs_2, fs_jpim1   ! vector opt. 
    412                   zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    413411                  ! total intermediate advective trends 
    414                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    415                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    416                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     412                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     413                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     414                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    417415                  ! update and guess with monotonic sheme 
    418                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
    419                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     416                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     417                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    420418               END DO 
    421419            END DO 
    … …  
    438436         ! -------------------------------------------------- 
    439437         ! antidiffusive flux on i and j 
    440  
    441  
    442          DO jk = 1, jpkm1 
    443  
     438         ! 
     439         DO jk = 1, jpkm1 
     440            ! 
    444441            DO jj = 1, jpjm1 
    445442               DO ji = 1, fs_jpim1   ! vector opt. 
    … …  
    472469         ! 
    473470         ztrs(:,:,:,1) = ptb(:,:,:,jn) 
     471         ztrs(:,:,1,2) = ptb(:,:,1,jn) 
     472         ztrs(:,:,1,3) = ptb(:,:,1,jn) 
    474473         zwzts(:,:,:) = 0._wp 
    475474 
    … …  
    564563      ! 
    565564                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
    566                    CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
     565                   CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
    567566                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    568567      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 
    … …  
    571570      ! 
    572571   END SUBROUTINE tra_adv_tvd_zts 
     572 
    573573 
    574574   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r5602 r7256  
    6868      ! 
    6969      rldf = 1     ! For active tracers the  
     70      r_fact_lap(:,:,:) = 1.0 
    7071 
    7172      IF( l_trdtra )   THEN                    !* Save ta and sa trends 
    … …  
    214215      IF( ierr == 1 )   CALL ctl_stop( ' iso-level in z-coordinate - partial step, not allowed' ) 
    215216      IF( ierr == 2 )   CALL ctl_stop( ' isoneutral bilaplacian operator does not exist' ) 
     217      IF( ln_traldf_grif .AND. ln_isfcav         )   & 
     218           CALL ctl_stop( ' ice shelf and traldf_grif not tested') 
    216219      IF( lk_traldf_eiv .AND. .NOT.ln_traldf_iso )   & 
    217220           CALL ctl_stop( '          eddy induced velocity on tracers',   & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r6772 r7256  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
     30   USE sbcisf          ! ice shelf melting/freezing 
    3031   USE zdf_oce         ! ocean vertical mixing 
    3132   USE domvvl          ! variable volume 
    … …  
    4647   USE timing          ! Timing 
    4748#if defined key_agrif 
    48    USE agrif_opa_update 
    4949   USE agrif_opa_interp 
    5050#endif 
    … …  
    112112      ! Update after tracer on domain lateral boundaries 
    113113      !  
     114#if defined key_agrif 
     115      CALL Agrif_tra                     ! AGRIF zoom boundaries 
     116#endif 
     117      ! 
    114118      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    115119      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    … …  
    117121#if defined key_bdy  
    118122      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    119 #endif 
    120 #if defined key_agrif 
    121       CALL Agrif_tra                     ! AGRIF zoom boundaries 
    122123#endif 
    123124  
    … …  
    150151         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    151152         ENDIF 
    152       ENDIF  
    153       ! 
    154 #if defined key_agrif 
    155       ! Update tracer at AGRIF zoom boundaries 
    156       IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
    157 #endif       
    158       ! 
    159       ! trends computation 
     153      ENDIF      
     154      ! 
     155     ! trends computation 
    160156      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    161157         DO jk = 1, jpkm1 
    … …  
    281277 
    282278      !!      
    283       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
     279      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf   ! local logical 
    284280      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    285281      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    297293         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    298294         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
     295         IF (nn_isf .GE. 1) THEN  
     296            ll_isf = .TRUE.            ! active  tracers case  and  ice shelf melting/freezing 
     297         ELSE 
     298            ll_isf = .FALSE. 
     299         END IF 
    299300      ELSE                           
    300301         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    301302         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    302303         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
     304         ll_isf     = .FALSE.          ! passive tracers or NO ice shelf melting/freezing 
    303305      ENDIF 
    304306      ! 
    … …  
    323325                  ztc_f  = ztc_n  + atfp * ztc_d 
    324326                  ! 
    325                   IF( jk == 1 ) THEN           ! first level  
    326                      ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
     327                  IF( jk == mikt(ji,jj) ) THEN           ! first level  
     328                     ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
     329                            &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
     330                            &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
    327331                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    328332                  ENDIF 
    329333 
    330                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
     334                  ! solar penetration (temperature only) 
     335                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
    331336                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    332337 
    333                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
     338                  ! river runoff 
     339                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
    334340                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    335341                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
     342 
     343                  ! ice shelf 
     344                  IF( ll_isf ) THEN 
     345                     ! level fully include in the Losch_2008 ice shelf boundary layer 
     346                     IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
     347                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     348                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
     349                     ! level partially include in Losch_2008 ice shelf boundary layer  
     350                     IF ( jk == misfkb(ji,jj) )                                                   & 
     351                        ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
     352                               &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
     353                  END IF 
    336354 
    337355                  ze3t_f = 1.e0 / ze3t_f 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r5602 r7256  
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            4.0  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     12   !!            3.4  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
     13   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
    1314   !!---------------------------------------------------------------------- 
    1415 
    … …  
    9394      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    9495      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
     96      !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 
    9597      !!---------------------------------------------------------------------- 
    9698      ! 
    … …  
    101103      REAL(wp) ::   zchl, zcoef, zfact   ! local scalars 
    102104      REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
    103       REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    104105      REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
     106      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
     107      REAL(wp) ::   zlogc, zlogc2, zlogc3  
    105108      REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
    106       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
    107       !!---------------------------------------------------------------------- 
     109      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 
     110      !!-------------------------------------------------------------------------- 
    108111      ! 
    109112      IF( nn_timing == 1 )  CALL timing_start('tra_qsr') 
    110113      ! 
    111114      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    112       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     115      CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    113116      ! 
    114117      IF( kt == nit000 ) THEN 
    … …  
    183186            !                                             ! ------------------------- ! 
    184187            ! Set chlorophyl concentration 
    185             IF( nn_chldta == 1 .OR. lk_vvl ) THEN            !*  Variable Chlorophyll or ocean volume 
    186                ! 
    187                IF( nn_chldta == 1 ) THEN                             !*  Variable Chlorophyll 
    188                   ! 
    189                   CALL fld_read( kt, 1, sf_chl )                         ! Read Chl data and provides it at the current time step 
    190                   !          
    191 !CDIR COLLAPSE 
     188            IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN    !*  Variable Chlorophyll or ocean volume 
     189               ! 
     190               IF( nn_chldta == 1 ) THEN        !*  2D Variable Chlorophyll 
     191                  ! 
     192                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     193                  DO jk = 1, nksr + 1 
     194                     zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1)  
     195                  ENDDO 
     196                  ! 
     197               ELSE IF( nn_chldta == 2 ) THEN    !*   -3-D Variable Chlorophyll 
     198                  ! 
     199                  CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
     200!CDIR NOVERRCHK   ! 
     201                  DO jj = 1, jpj 
    192202!CDIR NOVERRCHK 
    193                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    194 !CDIR NOVERRCHK 
    195                      DO ji = 1, jpi 
    196                         zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
    197                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    198                         zekb(ji,jj) = rkrgb(1,irgb) 
    199                         zekg(ji,jj) = rkrgb(2,irgb) 
    200                         zekr(ji,jj) = rkrgb(3,irgb) 
    201                      END DO 
    202                   END DO 
    203                ELSE                                            ! Variable ocean volume but constant chrlorophyll 
    204                   zchl = 0.05                                     ! constant chlorophyll 
    205                   irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
    206                   zekb(:,:) = rkrgb(1,irgb)                       ! Separation in R-G-B depending of the chlorophyll  
    207                   zekg(:,:) = rkrgb(2,irgb) 
    208                   zekr(:,:) = rkrgb(3,irgb) 
     203                     DO ji = 1, jpi 
     204                        zchl    = sf_chl(1)%fnow(ji,jj,1) 
     205                        zCtot   = 40.6  * zchl**0.459 
     206                        zze     = 568.2 * zCtot**(-0.746) 
     207                        IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
     208                        zlogc   = LOG( zchl ) 
     209                        zlogc2  = zlogc * zlogc 
     210                        zlogc3  = zlogc * zlogc * zlogc 
     211                        zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
     212                        zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
     213                        zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
     214                        zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
     215                        zCze    = 1.12  * (zchl)**0.803  
     216                        DO jk = 1, nksr + 1 
     217                           zpsi = fsdept(ji,jj,jk) / zze 
     218                           zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
     219                        END DO 
     220                        ! 
     221                      END DO 
     222                   END DO 
     223                     ! 
     224               ELSE                              !* Variable ocean volume but constant chrlorophyll 
     225                  DO jk = 1, nksr + 1 
     226                     zchl3d(:,:,jk) = 0.05  
     227                  ENDDO 
    209228               ENDIF 
    210229               ! 
    211                zcoef  = ( 1. - rn_abs ) / 3.e0                        ! equi-partition in R-G-B 
     230               zcoef  = ( 1. - rn_abs ) / 3.e0                        !  equi-partition in R-G-B 
    212231               ze0(:,:,1) = rn_abs  * qsr(:,:) 
    213232               ze1(:,:,1) = zcoef * qsr(:,:) 
    … …  
    217236               ! 
    218237               DO jk = 2, nksr+1 
     238                  ! 
     239                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of vertical profile of Chl 
     240!CDIR NOVERRCHK 
     241                     DO ji = 1, jpi 
     242                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
     243                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     244                        zekb(ji,jj) = rkrgb(1,irgb) 
     245                        zekg(ji,jj) = rkrgb(2,irgb) 
     246                        zekr(ji,jj) = rkrgb(3,irgb) 
     247                     END DO 
     248                  END DO 
    219249!CDIR NOVERRCHK 
    220250                  DO jj = 1, jpj 
    … …  
    233263                  END DO 
    234264               END DO 
    235                ! clem: store attenuation coefficient of the first ocean level 
    236                IF ( ln_qsr_ice ) THEN 
    237                   DO jj = 1, jpj 
    238                      DO ji = 1, jpi 
    239                         zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
    240                         zzc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
    241                         zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    242                         zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    243                         fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
    244                      END DO 
    245                   END DO 
    246                ENDIF 
    247265               ! 
    248266               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    … …  
    251269               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    252270               CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
     271               ! 
     272               IF ( ln_qsr_ice ) THEN    ! store attenuation coefficient of the first ocean level 
     273!CDIR NOVERRCHK 
     274                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
     275!CDIR NOVERRCHK 
     276                     DO ji = 1, jpi 
     277                        zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 
     278                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     279                        zekb(ji,jj) = rkrgb(1,irgb) 
     280                        zekg(ji,jj) = rkrgb(2,irgb) 
     281                        zekr(ji,jj) = rkrgb(3,irgb) 
     282                     END DO 
     283                  END DO 
     284                  !  
     285                  DO jj = 1, jpj 
     286                     DO ji = 1, jpi 
     287                        zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
     288                        zc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
     289                        zc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
     290                        zc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
     291                        fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2  + zc3  ) * tmask(ji,jj,2)  
     292                     END DO 
     293                  END DO 
     294                  ! 
     295               ENDIF 
    253296               ! 
    254297            ELSE                                                 !*  Constant Chlorophyll 
    … …  
    256299                  qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    257300               END DO 
    258                ! clem: store attenuation coefficient of the first ocean level 
    259                IF ( ln_qsr_ice ) THEN 
     301               ! store attenuation coefficient of the first ocean level 
     302               IF( ln_qsr_ice ) THEN 
    260303                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    261304               ENDIF 
    … …  
    339382      ! 
    340383      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    341       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
     384      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
    342385      ! 
    343386      IF( nn_timing == 1 )  CALL timing_stop('tra_qsr') 
    … …  
    405448         WRITE(numout,*) '      bio-model            light penetration   ln_qsr_bio = ', ln_qsr_bio 
    406449         WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice 
    407          WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)    nn_chldta  = ', nn_chldta 
     450         WRITE(numout,*) '      RGB : Chl data (=1/2) or cst value (=0)  nn_chldta  = ', nn_chldta 
    408451         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs = ', rn_abs 
    409452         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    … …  
    429472         IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr =  1  
    430473         IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr =  2 
    431          IF( ln_qsr_2bd                      )   nqsr =  3 
    432          IF( ln_qsr_bio                      )   nqsr =  4 
     474         IF( ln_qsr_rgb .AND. nn_chldta == 2 )   nqsr =  3 
     475         IF( ln_qsr_2bd                      )   nqsr =  4 
     476         IF( ln_qsr_bio                      )   nqsr =  5 
    433477         ! 
    434478         IF(lwp) THEN                   ! Print the choice 
    435479            WRITE(numout,*) 
    436480            IF( nqsr ==  1 )   WRITE(numout,*) '         R-G-B   light penetration - Constant Chlorophyll' 
    437             IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - Chl data ' 
    438             IF( nqsr ==  3 )   WRITE(numout,*) '         2 bands light penetration' 
    439             IF( nqsr ==  4 )   WRITE(numout,*) '         bio-model light penetration' 
     481            IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - 2D Chl data ' 
     482            IF( nqsr ==  3 )   WRITE(numout,*) '         R-G-B   light penetration - 3D Chl data ' 
     483            IF( nqsr ==  4 )   WRITE(numout,*) '         2 bands light penetration' 
     484            IF( nqsr ==  5 )   WRITE(numout,*) '         bio-model light penetration' 
    440485         ENDIF 
    441486         ! 
    … …  
    460505            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    461506            ! 
    462             IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
     507            IF( nn_chldta == 1  .OR. nn_chldta == 2 ) THEN           !* Chl data : set sf_chl structure 
    463508               IF(lwp) WRITE(numout,*) 
    464509               IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r5602 r7256  
    120120      REAL(wp) ::   zfact, z1_e3t, zdep 
    121121      REAL(wp) ::   zalpha, zhk 
    122       REAL(wp) ::  zt_frz, zpress 
    123122      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    124123      !!---------------------------------------------------------------------- 
    … …  
    159158         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    160159            zfact = 1._wp 
     160            sbc_tsc(:,:,:) = 0._wp 
    161161            sbc_tsc_b(:,:,:) = 0._wp 
    162162         ENDIF 
    … …  
    232232               DO jk = ikt, ikb - 1 
    233233               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    234 !                  zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    235                   zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    236234               ! compute trend 
    237235                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    238                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    239                      &               - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 
    240                      &           * r1_hisf_tbl(ji,jj) 
     236                     &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
    241237                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    242238                     &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    … …  
    245241               ! level partially include in ice shelf boundary layer  
    246242               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
    247 !               zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 
    248                zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 
    249243               ! compute trend 
    250244               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    251                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
    252                   &                  - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) &  
    253                   &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
     245                  &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    254246               tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    255247                  &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  
    … …  
    287279         END DO   
    288280      ENDIF 
    289   
     281 
     282      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     283      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     284 
    290285      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    291286         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    r5602 r7256  
    117117      ! 
    118118      SELECT CASE( ktrd ) 
    119          CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
    120          CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
    121          CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
    122          CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
    123          CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
    124          CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
    125          CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
    126          CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
    127          CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
    128          CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
     119        CASE( jpdyn_hpg )   ;   CALL iom_put( "ketrd_hpg", zke )    ! hydrostatic pressure gradient 
     120        CASE( jpdyn_spg )   ;   CALL iom_put( "ketrd_spg", zke )    ! surface pressure gradient 
     121        CASE( jpdyn_spgexp );   CALL iom_put( "ketrd_spgexp", zke ) ! surface pressure gradient (explicit) 
     122        CASE( jpdyn_spgflt );   CALL iom_put( "ketrd_spgflt", zke ) ! surface pressure gradient (filter) 
     123        CASE( jpdyn_pvo )   ;   CALL iom_put( "ketrd_pvo", zke )    ! planetary vorticity 
     124        CASE( jpdyn_rvo )   ;   CALL iom_put( "ketrd_rvo", zke )    ! relative  vorticity     (or metric term) 
     125        CASE( jpdyn_keg )   ;   CALL iom_put( "ketrd_keg", zke )    ! Kinetic Energy gradient (or had) 
     126        CASE( jpdyn_zad )   ;   CALL iom_put( "ketrd_zad", zke )    ! vertical   advection 
     127        CASE( jpdyn_ldf )   ;   CALL iom_put( "ketrd_ldf", zke )    ! lateral diffusion 
     128        CASE( jpdyn_zdf )   ;   CALL iom_put( "ketrd_zdf", zke )    ! vertical diffusion  
    129129                                 !                                   ! wind stress trends 
    130                                  CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
    131                            z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
    132                            z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
    133                            zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
    134                            DO jj = 2, jpj 
    135                               DO ji = 2, jpi 
    136                                  zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
    137                                  &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
    138                               END DO 
    139                            END DO 
    140                                  CALL iom_put( "ketrd_tau", zke2d ) 
    141                                  CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
    142          CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
     130                                CALL wrk_alloc( jpi, jpj, z2dx, z2dy, zke2d ) 
     131                     z2dx(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1u(:,:) * e2u(:,:) * umask(:,:,1) 
     132                     z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1v(:,:) * e2v(:,:) * vmask(:,:,1) 
     133                     zke2d(1,:) = 0._wp   ;   zke2d(:,1) = 0._wp 
     134                     DO jj = 2, jpj 
     135                         DO ji = 2, jpi 
     136                           zke2d(ji,jj) = 0.5_wp * (   z2dx(ji,jj) + z2dx(ji-1,jj)   & 
     137                            &                         + z2dy(ji,jj) + z2dy(ji,jj-1)   ) * r1_bt(ji,jj,1) 
     138                         END DO 
     139                     END DO 
     140                                CALL iom_put( "ketrd_tau", zke2d ) 
     141                                CALL wrk_dealloc( jpi, jpj     , z2dx, z2dy, zke2d ) 
     142        CASE( jpdyn_bfr )   ;   CALL iom_put( "ketrd_bfr", zke )    ! bottom friction (explicit case)  
    143143!!gm TO BE DONE properly 
    144144!!gm only valid if ln_bfrimp=F otherwise the bottom stress as to be recomputed at the end of the computation.... 
    … …  
    162162!         ENDIF 
    163163!!gm end 
    164          CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
     164        CASE( jpdyn_atf )   ;   CALL iom_put( "ketrd_atf", zke )    ! asselin filter trends  
    165165!! a faire !!!!  idee changer dynnxt pour avoir un appel a jpdyn_bfr avant le swap !!! 
    166166!! reflechir a une possible sauvegarde du "vrai" un,vn pour le calcul de atf.... 
    … …  
    184184!                              CALL iom_put( "ketrd_bfri", zke2d ) 
    185185!         ENDIF 
    186          CASE( jpdyn_ken )   ;   ! kinetic energy 
    187                            ! called in dynnxt.F90 before asselin time filter 
    188                            ! with putrd=ua and pvtrd=va 
    189                            zke(:,:,:) = 0.5_wp * zke(:,:,:) 
    190                            CALL iom_put( "KE", zke ) 
    191                            ! 
    192                            CALL ken_p2k( kt , zke ) 
    193                            CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
     186        CASE( jpdyn_ken )   ;   ! kinetic energy 
     187                    ! called in dynnxt.F90 before asselin time filter 
     188                    ! with putrd=ua and pvtrd=va 
     189                    zke(:,:,:) = 0.5_wp * zke(:,:,:) 
     190                    CALL iom_put( "KE", zke ) 
     191                    ! 
     192                    CALL ken_p2k( kt , zke ) 
     193                      CALL iom_put( "ketrd_convP2K", zke )     ! conversion -rau*g*w 
    194194         ! 
    195195      END SELECT 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

    r5602 r7256  
    165165 
    166166 
    167       SELECT CASE( ktrd ) 
    168       CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
     167      SELECT CASE( ktrd ) 
     168      CASE( jptra_npc  )               ! non-penetrative convection: regrouped with zdf 
    169169!!gm : to be completed !  
    170 !        IF( .... 
     170!         IF( .... 
    171171!!gm end 
    172       CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
    173          !                                   ! regroup iso-neutral diffusion in one term 
     172      CASE( jptra_zdfp )               ! iso-neutral diffusion: "pure" vertical diffusion 
     173         !                                   ! regroup iso-neutral diffusion in one term 
    174174         tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) ) 
    175175         smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) ) 
    … …  
    811811 
    812812 
    813       nkstp     = nit000 - 1              ! current time step indicator initialization 
     813      nkstp     = nit000 - 1              ! current time step indicator initialization 
    814814 
    815815 
    … …  
    851851      IF( nn_ctls == 1 ) THEN 
    852852         CALL ctl_opn( inum, 'ctlsurf_idx', 'OLD', 'UNFORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    853          READ ( inum ) nbol 
     853         READ ( inum, * ) nbol 
    854854         CLOSE( inum ) 
    855855      END IF 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

    r5602 r7256  
    1515 
    1616   !                                                !* mixed layer trend indices 
    17    INTEGER, PUBLIC, PARAMETER ::   jpltrd = 11      !: number of mixed-layer trends arrays 
     17   INTEGER, PUBLIC, PARAMETER ::   jpltrd = 12      !: number of mixed-layer trends arrays 
    1818   INTEGER, PUBLIC            ::   jpktrd           !: max level for mixed-layer trends diag. 
    1919   ! 
    … …  
    2828   INTEGER, PUBLIC, PARAMETER ::   jpmxl_for =  9   !: forcing  
    2929   INTEGER, PUBLIC, PARAMETER ::   jpmxl_dmp = 10   !: internal restoring trend 
    30    INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11   !: asselin trend (**MUST BE THE LAST ONE**) 
    31    INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12   !: asselin trend (**MUST BE THE LAST ONE**) 
     30   INTEGER, PUBLIC, PARAMETER ::   jpmxl_zdfp = 11  !: iso-neutral diffusion:"pure" vertical diffusion 
     31   INTEGER, PUBLIC, PARAMETER ::   jpmxl_atf  = 12  !: asselin trend (**MUST BE THE LAST ONE**) 
    3232   !                                                            !!* Namelist namtrd_mxl:  trend diagnostics in the mixed layer * 
    3333   INTEGER           , PUBLIC ::   nn_ctls  = 0                  !: control surface type for trends vertical integration 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

    r5602 r7256  
    9999                                   CALL wrk_alloc( jpi, jpj, z2d ) 
    100100                                   z2d(:,:) = wn(:,:,1) * ( & 
    101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
    102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
    103                                       &                  ) / fse3t(:,:,1) 
     101                                       &   - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem)    & 
     102                                       &   + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal)    & 
     103                                       &             ) / fse3t(:,:,1) 
    104104                                   CALL iom_put( "petrd_sad" , z2d ) 
    105105                                   CALL wrk_dealloc( jpi, jpj, z2d ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

    r4990 r7256  
    4343   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avmu , avmv    !: vertical viscosity coef at uw- & vw-pts       [m2/s] 
    4444   REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) ::   avm  , avt     !: vertical viscosity & diffusivity coef at w-pt [m2/s] 
     45   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     46   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en              !: now turbulent kinetic energy   [m2/s2] 
    4548  
    4649   !!---------------------------------------------------------------------- 
    … …  
    6063         &     tfrua(jpi, jpj), tfrva(jpi, jpj)              ,      & 
    6164         &     avmu(jpi,jpj,jpk), avm(jpi,jpj,jpk)           ,      & 
    62          &     avmv(jpi,jpj,jpk), avt(jpi,jpj,jpk)           , STAT = zdf_oce_alloc ) 
     65         &     avmv  (jpi,jpj,jpk), avt   (jpi,jpj,jpk)      ,      & 
     66         &     avt_k (jpi,jpj,jpk), avm_k (jpi,jpj,jpk)      ,      &  
     67         &     avmu_k(jpi,jpj,jpk), avmv_k(jpi,jpj,jpk)      ,      & 
     68         &     en    (jpi,jpj,jpk), STAT = zdf_oce_alloc ) 
    6369         ! 
    6470      IF( zdf_oce_alloc /= 0 )   CALL ctl_warn('zdf_oce_alloc: failed to allocate arrays') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

    r5602 r7256  
    177177                  &                             +  0.15 * zrau(ji,jj)          * zmskd2(ji,jj)  ) 
    178178               ! add to the eddy viscosity coef. previously computed 
     179# if defined key_zdftmx_new 
     180               ! key_zdftmx_new: New internal wave-driven param: use avs value computed by zdftmx 
     181               avs (ji,jj,jk) = avs(ji,jj,jk) + zavfs + zavds 
     182# else 
    179183               avs (ji,jj,jk) = avt(ji,jj,jk) + zavfs + zavds 
     184# endif 
    180185               avt (ji,jj,jk) = avt(ji,jj,jk) + zavft + zavdt 
    181186               avm (ji,jj,jk) = avm(ji,jj,jk) + MAX( zavft + zavdt, zavfs + zavds ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r5602 r7256  
    4242   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag 
    4343   ! 
    44    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
    4544   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    4645   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k   ! not enhanced Kz 
    48    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k   ! not enhanced Kz 
    49    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k  ! not enhanced Kz 
    50    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmv_k  ! not enhanced Kz 
    5146   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    5247   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
    … …  
    120115      !!                ***  FUNCTION zdf_gls_alloc  *** 
    121116      !!---------------------------------------------------------------------- 
    122       ALLOCATE( en(jpi,jpj,jpk),  mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
    123          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                    & 
    124          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk),                    & 
    125          &      ustars2(jpi,jpj), ustarb2(jpi,jpj)                      , STAT= zdf_gls_alloc ) 
     117      ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
     118         &      ustars2(jpi,jpj) , ustarb2(jpi,jpj)   , STAT= zdf_gls_alloc ) 
    126119         ! 
    127120      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc ) 
    … …  
    329322      !  
    330323      ! One level below 
    331       en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     324      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 
     325          &            / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
    332326      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
    333327      z_elem_a(:,:,2) = 0._wp  
    … …  
    350344      z_elem_a(:,:,2) = 0._wp 
    351345      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
    352       zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
     346      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 
     347           &                      * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
    353348 
    354349      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6101 r7256  
    2727 
    2828   PUBLIC   zdf_mxl       ! called by step.F90 
     29   PUBLIC   zdf_mxl_alloc ! Used in zdf_tke_init 
    2930 
    3031   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
    … …  
    7980      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8081      ! 
    81       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    82       INTEGER  ::   iikn, iiki, ikt, imkt  ! local integer 
    83       REAL(wp) ::   zN2_c        ! local scalar 
     82      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     83      INTEGER  ::   iikn, iiki, ikt ! local integer 
     84      REAL(wp) ::   zN2_c           ! local scalar 
    8485      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    8586      REAL(wp), POINTER, DIMENSION(:,:) ::   z2d   ! 2D workspace 
    … …  
    118119         DO jj = 1, jpj 
    119120            DO ji = 1, jpi 
    120                imkt = mikt(ji,jj) 
    121                IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
     121               IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
    122122            END DO 
    123123         END DO 
    … …  
    128128            iiki = imld(ji,jj) 
    129129            iikn = nmln(ji,jj) 
    130             imkt = mikt(ji,jj) 
    131             hmld (ji,jj) = ( fsdepw(ji,jj,iiki  ) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! Turbocline depth  
    132             hmlp (ji,jj) = ( fsdepw(ji,jj,iikn  ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
    133             hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
     130            hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
     131            hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth 
     132            hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    134133         END DO 
    135134      END DO 
    136       CALL iom_put("hmlpt",hmlpt) 
    137  
    138       IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    139          CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
    140          CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
    141          z2d(:,:)=REAL(nmln,wp)  
    142          CALL iom_put( "nmln"  , z2d )   ! turbocline depth 
     135      ! no need to output in offline mode 
     136      IF( .NOT.lk_offline ) THEN    
     137         IF ( iom_use("mldr10_1") ) THEN 
     138            IF( ln_isfcav ) THEN 
     139               CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     140            ELSE 
     141               CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     142            END IF 
     143         END IF 
     144         IF ( iom_use("mldkz5") ) THEN 
     145            IF( ln_isfcav ) THEN 
     146               CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     147            ELSE 
     148               CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     149            END IF 
     150         END IF 
    143151      ENDIF 
    144152       

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90

    r4624 r7256  
    162162                  &                               + avmv(ji,jj,jk) + avmv(ji,jj-1,jk)  )   & 
    163163                  &          + avtb(jk) * tmask(ji,jj,jk) 
    164                !                                            ! Add the background coefficient on eddy viscosity 
     164            END DO 
     165         END DO 
     166         DO jj = 2, jpjm1                                   ! Add the background coefficient on eddy viscosity 
     167            DO ji = 2, jpim1 
    165168               avmu(ji,jj,jk) = avmu(ji,jj,jk) + avmb(jk) * umask(ji,jj,jk) 
    166169               avmv(ji,jj,jk) = avmv(ji,jj,jk) + avmb(jk) * vmask(ji,jj,jk) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r6101 r7256  
    5353   USE timing         ! Timing 
    5454   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     55#if defined key_agrif 
     56   USE agrif_opa_interp 
     57   USE agrif_opa_update 
     58#endif 
     59 
     60 
    5561 
    5662   IMPLICIT NONE 
    … …  
    8591   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    8692 
    87    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy   [m2/s2] 
    8893   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    8994   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
    90    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
    91    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9295#if defined key_c1d 
    9396   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    115118         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    116119#endif 
    117          &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
    118          &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
    119          &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
     120         &      htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc      ) 
    120121         ! 
    121122      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    … …  
    189190      avmv_k(:,:,:) = avmv(:,:,:)  
    190191      ! 
     192#if defined key_agrif 
     193      ! Update child grid f => parent grid  
     194      IF( .NOT.Agrif_Root() )   CALL Agrif_Update_Tke( kt )      ! children only 
     195#endif       
     196     !  
    191197   END SUBROUTINE zdf_tke 
    192198 
    … …  
    317323                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    318324                  !                                           ! TKE Langmuir circulation source term 
    319                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     325                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
     326                     &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    320327               END DO 
    321328            END DO 
    … …  
    350357            DO ji = fs_2, fs_jpim1   ! vector opt. 
    351358               zcof   = zfact1 * tmask(ji,jj,jk) 
     359# if defined key_zdftmx_new 
     360               ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
     361               zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) )   &  ! upper diagonal 
     362                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
     363               zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) )   &  ! lower diagonal 
     364                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     365# else 
    352366               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    353367                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    354368               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    355369                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
     370# endif 
    356371                  !                                                           ! shear prod. at w-point weightened by mask 
    357372               zesh2  =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 
    … …  
    710725      !!---------------------------------------------------------------------- 
    711726      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    712       INTEGER ::   ios 
     727      INTEGER ::   ios, ierr 
    713728      !! 
    714729      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,   & 
    … …  
    728743      ! 
    729744      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number 
     745# if defined key_zdftmx_new 
     746      ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 
     747      rn_emin  = 1.e-10_wp 
     748      rmxl_min = 1.e-03_wp 
     749      IF(lwp) THEN                  ! Control print 
     750         WRITE(numout,*) 
     751         WRITE(numout,*) 'zdf_tke_init :  New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 
     752         WRITE(numout,*) '~~~~~~~~~~~~' 
     753      ENDIF 
     754# else 
    730755      rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity 
     756# endif 
    731757      ! 
    732758      IF(lwp) THEN                    !* Control print 
    … …  
    768794      ENDIF 
    769795       
    770       IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln  
     796      IF( nn_etau == 2  ) THEN 
     797          ierr = zdf_mxl_alloc() 
     798          nmln(:,:) = nlb10           ! Initialization of nmln 
     799      ENDIF 
    771800 
    772801      !                               !* depth of penetration of surface tke 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r5602 r7256  
    561561   END SUBROUTINE zdf_tmx_init 
    562562 
     563#elif defined key_zdftmx_new 
     564   !!---------------------------------------------------------------------- 
     565   !!   'key_zdftmx_new'               Internal wave-driven vertical mixing 
     566   !!---------------------------------------------------------------------- 
     567   !!   zdf_tmx       : global     momentum & tracer Kz with wave induced Kz 
     568   !!   zdf_tmx_init  : global     momentum & tracer Kz with wave induced Kz 
     569   !!---------------------------------------------------------------------- 
     570   USE oce            ! ocean dynamics and tracers variables 
     571   USE dom_oce        ! ocean space and time domain variables 
     572   USE zdf_oce        ! ocean vertical physics variables 
     573   USE zdfddm         ! ocean vertical physics: double diffusive mixing 
     574   USE lbclnk         ! ocean lateral boundary conditions (or mpp link) 
     575   USE eosbn2         ! ocean equation of state 
     576   USE phycst         ! physical constants 
     577   USE prtctl         ! Print control 
     578   USE in_out_manager ! I/O manager 
     579   USE iom            ! I/O Manager 
     580   USE lib_mpp        ! MPP library 
     581   USE wrk_nemo       ! work arrays 
     582   USE timing         ! Timing 
     583   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
     584 
     585   IMPLICIT NONE 
     586   PRIVATE 
     587 
     588   PUBLIC   zdf_tmx         ! called in step module  
     589   PUBLIC   zdf_tmx_init    ! called in nemogcm module  
     590   PUBLIC   zdf_tmx_alloc   ! called in nemogcm module 
     591 
     592   LOGICAL, PUBLIC, PARAMETER ::   lk_zdftmx = .TRUE.    !: wave-driven mixing flag 
     593 
     594   !                       !!* Namelist  namzdf_tmx : internal wave-driven mixing * 
     595   INTEGER  ::  nn_zpyc     ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) 
     596   LOGICAL  ::  ln_mevar    ! variable (=T) or constant (=F) mixing efficiency 
     597   LOGICAL  ::  ln_tsdiff   ! account for differential T/S wave-driven mixing (=T) or not (=F) 
     598 
     599   REAL(wp) ::  r1_6 = 1._wp / 6._wp 
     600 
     601   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ebot_tmx     ! power available from high-mode wave breaking (W/m2) 
     602   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   epyc_tmx     ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) 
     603   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ecri_tmx     ! power available from low-mode, critical slope wave breaking (W/m2) 
     604   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hbot_tmx     ! WKB decay scale for high-mode energy dissipation (m) 
     605   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   hcri_tmx     ! decay scale for low-mode critical slope dissipation (m) 
     606   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   emix_tmx     ! local energy density available for mixing (W/kg) 
     607   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bflx_tmx     ! buoyancy flux Kz * N^2 (W/kg) 
     608   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   pcmap_tmx    ! vertically integrated buoyancy flux (W/m2) 
     609   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_ratio    ! S/T diffusivity ratio (only for ln_tsdiff=T) 
     610   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zav_wave     ! Internal wave-induced diffusivity 
     611 
     612   !! * Substitutions 
     613#  include "zdfddm_substitute.h90" 
     614#  include "domzgr_substitute.h90" 
     615#  include "vectopt_loop_substitute.h90" 
     616   !!---------------------------------------------------------------------- 
     617   !! NEMO/OPA 4.0 , NEMO Consortium (2016) 
     618   !! $Id$ 
     619   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     620   !!---------------------------------------------------------------------- 
     621CONTAINS 
     622 
     623   INTEGER FUNCTION zdf_tmx_alloc() 
     624      !!---------------------------------------------------------------------- 
     625      !!                ***  FUNCTION zdf_tmx_alloc  *** 
     626      !!---------------------------------------------------------------------- 
     627      ALLOCATE(     ebot_tmx(jpi,jpj),  epyc_tmx(jpi,jpj),  ecri_tmx(jpi,jpj)    ,   & 
     628      &             hbot_tmx(jpi,jpj),  hcri_tmx(jpi,jpj),  emix_tmx(jpi,jpj,jpk),   & 
     629      &         bflx_tmx(jpi,jpj,jpk), pcmap_tmx(jpi,jpj), zav_ratio(jpi,jpj,jpk),   &  
     630      &         zav_wave(jpi,jpj,jpk), STAT=zdf_tmx_alloc     ) 
     631      ! 
     632      IF( lk_mpp             )   CALL mpp_sum ( zdf_tmx_alloc ) 
     633      IF( zdf_tmx_alloc /= 0 )   CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays') 
     634   END FUNCTION zdf_tmx_alloc 
     635 
     636 
     637   SUBROUTINE zdf_tmx( kt ) 
     638      !!---------------------------------------------------------------------- 
     639      !!                  ***  ROUTINE zdf_tmx  *** 
     640      !!                    
     641      !! ** Purpose :   add to the vertical mixing coefficients the effect of 
     642      !!              breaking internal waves. 
     643      !! 
     644      !! ** Method  : - internal wave-driven vertical mixing is given by: 
     645      !!                  Kz_wave = min(  100 cm2/s, f(  Reb = emix_tmx /( Nu * N^2 )  ) 
     646      !!              where emix_tmx is the 3D space distribution of the wave-breaking  
     647      !!              energy and Nu the molecular kinematic viscosity. 
     648      !!              The function f(Reb) is linear (constant mixing efficiency) 
     649      !!              if the namelist parameter ln_mevar = F and nonlinear if ln_mevar = T. 
     650      !! 
     651      !!              - Compute emix_tmx, the 3D power density that allows to compute 
     652      !!              Reb and therefrom the wave-induced vertical diffusivity. 
     653      !!              This is divided into three components: 
     654      !!                 1. Bottom-intensified low-mode dissipation at critical slopes 
     655      !!                     emix_tmx(z) = ( ecri_tmx / rau0 ) * EXP( -(H-z)/hcri_tmx ) 
     656      !!                                   / ( 1. - EXP( - H/hcri_tmx ) ) * hcri_tmx 
     657      !!              where hcri_tmx is the characteristic length scale of the bottom  
     658      !!              intensification, ecri_tmx a map of available power, and H the ocean depth. 
     659      !!                 2. Pycnocline-intensified low-mode dissipation 
     660      !!                     emix_tmx(z) = ( epyc_tmx / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) 
     661      !!                                   / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) 
     662      !!              where epyc_tmx is a map of available power, and nn_zpyc 
     663      !!              is the chosen stratification-dependence of the internal wave 
     664      !!              energy dissipation. 
     665      !!                 3. WKB-height dependent high mode dissipation 
     666      !!                     emix_tmx(z) = ( ebot_tmx / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_tmx) 
     667      !!                                   / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_tmx) * e3w(z) ) 
     668      !!              where hbot_tmx is the characteristic length scale of the WKB bottom  
     669      !!              intensification, ebot_tmx is a map of available power, and z_wkb is the 
     670      !!              WKB-stretched height above bottom defined as 
     671      !!                    z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) 
     672      !!                                 / SUM( sqrt(rn2(z'))    * e3w(z')    ) 
     673      !! 
     674      !!              - update the model vertical eddy viscosity and diffusivity:  
     675      !!                     avt  = avt  +    av_wave 
     676      !!                     avm  = avm  +    av_wave 
     677      !!                     avmu = avmu + mi(av_wave) 
     678      !!                     avmv = avmv + mj(av_wave) 
     679      !! 
     680      !!              - if namelist parameter ln_tsdiff = T, account for differential mixing: 
     681      !!                     avs  = avt  +    av_wave * diffusivity_ratio(Reb) 
     682      !! 
     683      !! ** Action  : - Define emix_tmx used to compute internal wave-induced mixing 
     684      !!              - avt, avs, avm, avmu, avmv increased by internal wave-driven mixing     
     685      !! 
     686      !! References :  de Lavergne et al. 2015, JPO; 2016, in prep. 
     687      !!---------------------------------------------------------------------- 
     688      INTEGER, INTENT(in) ::   kt   ! ocean time-step  
     689      ! 
     690      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     691      REAL(wp) ::   ztpc         ! scalar workspace 
     692      REAL(wp), DIMENSION(:,:)  , POINTER ::  zfact     ! Used for vertical structure 
     693      REAL(wp), DIMENSION(:,:)  , POINTER ::  zhdep     ! Ocean depth 
     694      REAL(wp), DIMENSION(:,:,:), POINTER ::  zwkb      ! WKB-stretched height above bottom 
     695      REAL(wp), DIMENSION(:,:,:), POINTER ::  zweight   ! Weight for high mode vertical distribution 
     696      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_t     ! Molecular kinematic viscosity (T grid) 
     697      REAL(wp), DIMENSION(:,:,:), POINTER ::  znu_w     ! Molecular kinematic viscosity (W grid) 
     698      REAL(wp), DIMENSION(:,:,:), POINTER ::  zReb      ! Turbulence intensity parameter 
     699      !!---------------------------------------------------------------------- 
     700      ! 
     701      IF( nn_timing == 1 )   CALL timing_start('zdf_tmx') 
     702      ! 
     703      CALL wrk_alloc( jpi,jpj,       zfact, zhdep ) 
     704      CALL wrk_alloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     705 
     706      !                          ! ----------------------------- ! 
     707      !                          !  Internal wave-driven mixing  !  (compute zav_wave) 
     708      !                          ! ----------------------------- ! 
     709      !                              
     710      !                        !* Critical slope mixing: distribute energy over the time-varying ocean depth, 
     711      !                                                 using an exponential decay from the seafloor. 
     712      DO jj = 1, jpj                ! part independent of the level 
     713         DO ji = 1, jpi 
     714            zhdep(ji,jj) = fsdepw(ji,jj,mbkt(ji,jj)+1)       ! depth of the ocean 
     715            zfact(ji,jj) = rau0 * (  1._wp - EXP( -zhdep(ji,jj) / hcri_tmx(ji,jj) )  ) 
     716            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ecri_tmx(ji,jj) / zfact(ji,jj) 
     717         END DO 
     718      END DO 
     719 
     720      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     721         emix_tmx(:,:,jk) = zfact(:,:) * (  EXP( ( fsde3w(:,:,jk  ) - zhdep(:,:) ) / hcri_tmx(:,:) )                      & 
     722            &                             - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) )  ) * wmask(:,:,jk)   & 
     723            &                          / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     724      END DO 
     725 
     726      !                        !* Pycnocline-intensified mixing: distribute energy over the time-varying  
     727      !                        !* ocean depth as proportional to sqrt(rn2)^nn_zpyc 
     728 
     729      SELECT CASE ( nn_zpyc ) 
     730 
     731      CASE ( 1 )               ! Dissipation scales as N (recommended) 
     732 
     733         zfact(:,:) = 0._wp 
     734         DO jk = 2, jpkm1              ! part independent of the level 
     735            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     736         END DO 
     737 
     738         DO jj = 1, jpj 
     739            DO ji = 1, jpi 
     740               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     741            END DO 
     742         END DO 
     743 
     744         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     745            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     746         END DO 
     747 
     748      CASE ( 2 )               ! Dissipation scales as N^2 
     749 
     750         zfact(:,:) = 0._wp 
     751         DO jk = 2, jpkm1              ! part independent of the level 
     752            zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     753         END DO 
     754 
     755         DO jj= 1, jpj 
     756            DO ji = 1, jpi 
     757               IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = epyc_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     758            END DO 
     759         END DO 
     760 
     761         DO jk = 2, jpkm1              ! complete with the level-dependent part 
     762            emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     763         END DO 
     764 
     765      END SELECT 
     766 
     767      !                        !* WKB-height dependent mixing: distribute energy over the time-varying  
     768      !                        !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) 
     769       
     770      zwkb(:,:,:) = 0._wp 
     771      zfact(:,:) = 0._wp 
     772      DO jk = 2, jpkm1 
     773         zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     774         zwkb(:,:,jk) = zfact(:,:) 
     775      END DO 
     776 
     777      DO jk = 2, jpkm1 
     778         DO jj = 1, jpj 
     779            DO ji = 1, jpi 
     780               IF( zfact(ji,jj) /= 0 )   zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) )   & 
     781                                            &           * tmask(ji,jj,jk) / zfact(ji,jj) 
     782            END DO 
     783         END DO 
     784      END DO 
     785      zwkb(:,:,1) = zhdep(:,:) * tmask(:,:,1) 
     786 
     787      zweight(:,:,:) = 0._wp 
     788      DO jk = 2, jpkm1 
     789         zweight(:,:,jk) = MAX( 0._wp, rn2(:,:,jk) ) * hbot_tmx(:,:) * wmask(:,:,jk)                    & 
     790            &   * (  EXP( -zwkb(:,:,jk) / hbot_tmx(:,:) ) - EXP( -zwkb(:,:,jk-1) / hbot_tmx(:,:) )  ) 
     791      END DO 
     792 
     793      zfact(:,:) = 0._wp 
     794      DO jk = 2, jpkm1              ! part independent of the level 
     795         zfact(:,:) = zfact(:,:) + zweight(:,:,jk) 
     796      END DO 
     797 
     798      DO jj = 1, jpj 
     799         DO ji = 1, jpi 
     800            IF( zfact(ji,jj) /= 0 )   zfact(ji,jj) = ebot_tmx(ji,jj) / ( rau0 * zfact(ji,jj) ) 
     801         END DO 
     802      END DO 
     803 
     804      DO jk = 2, jpkm1              ! complete with the level-dependent part 
     805         emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk)   & 
     806            &                                / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     807      END DO 
     808 
     809 
     810      ! Calculate molecular kinematic viscosity 
     811      znu_t(:,:,:) = 1.e-4_wp * (  17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem)  & 
     812         &                                  + 0.02305_wp * tsn(:,:,:,jp_sal)  ) * tmask(:,:,:) * r1_rau0 
     813      DO jk = 2, jpkm1 
     814         znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) 
     815      END DO 
     816 
     817      ! Calculate turbulence intensity parameter Reb 
     818      DO jk = 2, jpkm1 
     819         zReb(:,:,jk) = emix_tmx(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) 
     820      END DO 
     821 
     822      ! Define internal wave-induced diffusivity 
     823      DO jk = 2, jpkm1 
     824         zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6   ! This corresponds to a constant mixing efficiency of 1/6 
     825      END DO 
     826 
     827      IF( ln_mevar ) THEN              ! Variable mixing efficiency case : modify zav_wave in the 
     828         DO jk = 2, jpkm1              ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes 
     829            DO jj = 1, jpj 
     830               DO ji = 1, jpi 
     831                  IF( zReb(ji,jj,jk) > 480.00_wp ) THEN 
     832                     zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     833                  ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN 
     834                     zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) 
     835                  ENDIF 
     836               END DO 
     837            END DO 
     838         END DO 
     839      ENDIF 
     840 
     841      DO jk = 2, jpkm1                 ! Bound diffusivity by molecular value and 100 cm2/s 
     842         zav_wave(:,:,jk) = MIN(  MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp  ) * wmask(:,:,jk) 
     843      END DO 
     844 
     845      IF( kt == nit000 ) THEN        !* Control print at first time-step: diagnose the energy consumed by zav_wave 
     846         ztpc = 0._wp 
     847         DO jk = 2, jpkm1 
     848            DO jj = 1, jpj 
     849               DO ji = 1, jpi 
     850                  ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj)   & 
     851                     &         * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
     852               END DO 
     853            END DO 
     854         END DO 
     855         IF( lk_mpp )   CALL mpp_sum( ztpc ) 
     856         ztpc = rau0 * ztpc ! Global integral of rauo * Kz * N^2 = power contributing to mixing  
     857  
     858         IF(lwp) THEN 
     859            WRITE(numout,*) 
     860            WRITE(numout,*) 'zdf_tmx : Internal wave-driven mixing (tmx)' 
     861            WRITE(numout,*) '~~~~~~~ ' 
     862            WRITE(numout,*) 
     863            WRITE(numout,*) '      Total power consumption by av_wave: ztpc =  ', ztpc * 1.e-12_wp, 'TW' 
     864         ENDIF 
     865      ENDIF 
     866 
     867      !                          ! ----------------------- ! 
     868      !                          !   Update  mixing coefs  !                           
     869      !                          ! ----------------------- ! 
     870      !       
     871      IF( ln_tsdiff ) THEN          !* Option for differential mixing of salinity and temperature 
     872         DO jk = 2, jpkm1              ! Calculate S/T diffusivity ratio as a function of Reb 
     873            DO jj = 1, jpj 
     874               DO ji = 1, jpi 
     875                  zav_ratio(ji,jj,jk) = ( 0.505_wp + 0.495_wp *                                                                  & 
     876                      &   TANH(    0.92_wp * (   LOG10(  MAX( 1.e-20_wp, zReb(ji,jj,jk) * 5._wp * r1_6 )  ) - 0.60_wp   )    )   & 
     877                      &                 ) * wmask(ji,jj,jk) 
     878               END DO 
     879            END DO 
     880         END DO 
     881         CALL iom_put( "av_ratio", zav_ratio ) 
     882         DO jk = 2, jpkm1           !* update momentum & tracer diffusivity with wave-driven mixing 
     883            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) 
     884            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     885            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     886         END DO 
     887         ! 
     888      ELSE                          !* update momentum & tracer diffusivity with wave-driven mixing 
     889         DO jk = 2, jpkm1 
     890            fsavs(:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     891            avt  (:,:,jk) = avt(:,:,jk) + zav_wave(:,:,jk) 
     892            avm  (:,:,jk) = avm(:,:,jk) + zav_wave(:,:,jk) 
     893         END DO 
     894      ENDIF 
     895 
     896      DO jk = 2, jpkm1              !* update momentum diffusivity at wu and wv points 
     897         DO jj = 2, jpjm1 
     898            DO ji = fs_2, fs_jpim1  ! vector opt. 
     899               avmu(ji,jj,jk) = avmu(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji+1,jj  ,jk) ) * wumask(ji,jj,jk) 
     900               avmv(ji,jj,jk) = avmv(ji,jj,jk) + 0.5_wp * ( zav_wave(ji,jj,jk) + zav_wave(ji  ,jj+1,jk) ) * wvmask(ji,jj,jk) 
     901            END DO 
     902         END DO 
     903      END DO 
     904      CALL lbc_lnk( avmu, 'U', 1. )   ;   CALL lbc_lnk( avmv, 'V', 1. )      ! lateral boundary condition 
     905 
     906      !                             !* output internal wave-driven mixing coefficient 
     907      CALL iom_put( "av_wave", zav_wave ) 
     908                                    !* output useful diagnostics: N^2, Kz * N^2 (bflx_tmx),  
     909                                    !  vertical integral of rau0 * Kz * N^2 (pcmap_tmx), energy density (emix_tmx) 
     910      IF( iom_use("bflx_tmx") .OR. iom_use("pcmap_tmx") ) THEN 
     911         bflx_tmx(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) 
     912         pcmap_tmx(:,:) = 0._wp 
     913         DO jk = 2, jpkm1 
     914            pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 
     915         END DO 
     916         pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 
     917         CALL iom_put( "bflx_tmx", bflx_tmx ) 
     918         CALL iom_put( "pcmap_tmx", pcmap_tmx ) 
     919      ENDIF 
     920      CALL iom_put( "bn2", rn2 ) 
     921      CALL iom_put( "emix_tmx", emix_tmx ) 
     922       
     923      CALL wrk_dealloc( jpi,jpj,       zfact, zhdep ) 
     924      CALL wrk_dealloc( jpi,jpj,jpk,   zwkb, zweight, znu_t, znu_w, zReb ) 
     925 
     926      IF(ln_ctl)   CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' tmx - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', ovlap=1, kdim=jpk) 
     927      ! 
     928      IF( nn_timing == 1 )   CALL timing_stop('zdf_tmx') 
     929      ! 
     930   END SUBROUTINE zdf_tmx 
     931 
     932 
     933   SUBROUTINE zdf_tmx_init 
     934      !!---------------------------------------------------------------------- 
     935      !!                  ***  ROUTINE zdf_tmx_init  *** 
     936      !!                      
     937      !! ** Purpose :   Initialization of the wave-driven vertical mixing, reading 
     938      !!              of input power maps and decay length scales in netcdf files. 
     939      !! 
     940      !! ** Method  : - Read the namzdf_tmx namelist and check the parameters 
     941      !! 
     942      !!              - Read the input data in NetCDF files : 
     943      !!              power available from high-mode wave breaking (mixing_power_bot.nc) 
     944      !!              power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) 
     945      !!              power available from critical slope wave-breaking (mixing_power_cri.nc) 
     946      !!              WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) 
     947      !!              decay scale for critical slope wave-breaking (decay_scale_cri.nc) 
     948      !! 
     949      !! ** input   : - Namlist namzdf_tmx 
     950      !!              - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, 
     951      !!              decay_scale_bot.nc decay_scale_cri.nc 
     952      !! 
     953      !! ** Action  : - Increase by 1 the nstop flag is setting problem encounter 
     954      !!              - Define ebot_tmx, epyc_tmx, ecri_tmx, hbot_tmx, hcri_tmx 
     955      !! 
     956      !! References : de Lavergne et al. 2015, JPO; 2016, in prep. 
     957      !!          
     958      !!---------------------------------------------------------------------- 
     959      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     960      INTEGER  ::   inum         ! local integer 
     961      INTEGER  ::   ios 
     962      REAL(wp) ::   zbot, zpyc, zcri   ! local scalars 
     963      !! 
     964      NAMELIST/namzdf_tmx_new/ nn_zpyc, ln_mevar, ln_tsdiff 
     965      !!---------------------------------------------------------------------- 
     966      ! 
     967      IF( nn_timing == 1 )  CALL timing_start('zdf_tmx_init') 
     968      ! 
     969      REWIND( numnam_ref )              ! Namelist namzdf_tmx in reference namelist : Wave-driven mixing 
     970      READ  ( numnam_ref, namzdf_tmx_new, IOSTAT = ios, ERR = 901) 
     971901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in reference namelist', lwp ) 
     972      ! 
     973      REWIND( numnam_cfg )              ! Namelist namzdf_tmx in configuration namelist : Wave-driven mixing 
     974      READ  ( numnam_cfg, namzdf_tmx_new, IOSTAT = ios, ERR = 902 ) 
     975902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tmx in configuration namelist', lwp ) 
     976      IF(lwm) WRITE ( numond, namzdf_tmx_new ) 
     977      ! 
     978      IF(lwp) THEN                  ! Control print 
     979         WRITE(numout,*) 
     980         WRITE(numout,*) 'zdf_tmx_init : internal wave-driven mixing' 
     981         WRITE(numout,*) '~~~~~~~~~~~~' 
     982         WRITE(numout,*) '   Namelist namzdf_tmx_new : set wave-driven mixing parameters' 
     983         WRITE(numout,*) '      Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc 
     984         WRITE(numout,*) '      Variable (T) or constant (F) mixing efficiency            = ', ln_mevar 
     985         WRITE(numout,*) '      Differential internal wave-driven mixing (T) or not (F)   = ', ln_tsdiff 
     986      ENDIF 
     987       
     988      ! The new wave-driven mixing parameterization elevates avt and avm in the interior, and 
     989      ! ensures that avt remains larger than its molecular value (=1.4e-7). Therefore, avtb should  
     990      ! be set here to a very small value, and avmb to its (uniform) molecular value (=1.4e-6). 
     991      avmb(:) = 1.4e-6_wp        ! viscous molecular value 
     992      avtb(:) = 1.e-10_wp        ! very small diffusive minimum (background avt is specified in zdf_tmx)     
     993      avtb_2d(:,:) = 1.e0_wp     ! uniform  
     994      IF(lwp) THEN                  ! Control print 
     995         WRITE(numout,*) 
     996         WRITE(numout,*) '   Force the background value applied to avm & avt in TKE to be everywhere ',   & 
     997            &               'the viscous molecular value & a very small diffusive value, resp.' 
     998      ENDIF 
     999       
     1000      IF( .NOT.lk_zdfddm )   CALL ctl_stop( 'STOP', 'zdf_tmx_init_new : key_zdftmx_new requires key_zdfddm' ) 
     1001       
     1002      !                             ! allocate tmx arrays 
     1003      IF( zdf_tmx_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'zdf_tmx_init : unable to allocate tmx arrays' ) 
     1004      ! 
     1005      !                             ! read necessary fields 
     1006      CALL iom_open('mixing_power_bot',inum)       ! energy flux for high-mode wave breaking [W/m2] 
     1007      CALL iom_get  (inum, jpdom_data, 'field', ebot_tmx, 1 )  
     1008      CALL iom_close(inum) 
     1009      ! 
     1010      CALL iom_open('mixing_power_pyc',inum)       ! energy flux for pynocline-intensified wave breaking [W/m2] 
     1011      CALL iom_get  (inum, jpdom_data, 'field', epyc_tmx, 1 ) 
     1012      CALL iom_close(inum) 
     1013      ! 
     1014      CALL iom_open('mixing_power_cri',inum)       ! energy flux for critical slope wave breaking [W/m2] 
     1015      CALL iom_get  (inum, jpdom_data, 'field', ecri_tmx, 1 ) 
     1016      CALL iom_close(inum) 
     1017      ! 
     1018      CALL iom_open('decay_scale_bot',inum)        ! spatially variable decay scale for high-mode wave breaking [m] 
     1019      CALL iom_get  (inum, jpdom_data, 'field', hbot_tmx, 1 ) 
     1020      CALL iom_close(inum) 
     1021      ! 
     1022      CALL iom_open('decay_scale_cri',inum)        ! spatially variable decay scale for critical slope wave breaking [m] 
     1023      CALL iom_get  (inum, jpdom_data, 'field', hcri_tmx, 1 ) 
     1024      CALL iom_close(inum) 
     1025 
     1026      ebot_tmx(:,:) = ebot_tmx(:,:) * ssmask(:,:) 
     1027      epyc_tmx(:,:) = epyc_tmx(:,:) * ssmask(:,:) 
     1028      ecri_tmx(:,:) = ecri_tmx(:,:) * ssmask(:,:) 
     1029 
     1030      ! Set once for all to zero the first and last vertical levels of appropriate variables 
     1031      emix_tmx (:,:, 1 ) = 0._wp 
     1032      emix_tmx (:,:,jpk) = 0._wp 
     1033      zav_ratio(:,:, 1 ) = 0._wp 
     1034      zav_ratio(:,:,jpk) = 0._wp 
     1035      zav_wave (:,:, 1 ) = 0._wp 
     1036      zav_wave (:,:,jpk) = 0._wp 
     1037 
     1038      zbot = glob_sum( e1e2t(:,:) * ebot_tmx(:,:) ) 
     1039      zpyc = glob_sum( e1e2t(:,:) * epyc_tmx(:,:) ) 
     1040      zcri = glob_sum( e1e2t(:,:) * ecri_tmx(:,:) ) 
     1041      IF(lwp) THEN 
     1042         WRITE(numout,*) '      High-mode wave-breaking energy:             ', zbot * 1.e-12_wp, 'TW' 
     1043         WRITE(numout,*) '      Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' 
     1044         WRITE(numout,*) '      Critical slope wave-breaking energy:        ', zcri * 1.e-12_wp, 'TW' 
     1045      ENDIF 
     1046      ! 
     1047      IF( nn_timing == 1 )  CALL timing_stop('zdf_tmx_init') 
     1048      ! 
     1049   END SUBROUTINE zdf_tmx_init 
     1050 
    5631051#else 
    5641052   !!---------------------------------------------------------------------- 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r7217 r7256  
    8383   USE crsini          ! initialise grid coarsening utility 
    8484   USE lbcnfd, ONLY: isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges  
    85    USE trabbl_crs 
     85   !cbr USE trabbl_crs 
    8686   USE sbc_oce, ONLY: lk_oasis 
    8787   USE stopar 
    … …  
    164164          ENDIF 
    165165 
     166#if defined key_agrif 
     167          CALL Agrif_Regrid() 
     168#endif 
     169 
    166170         DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    167171#if defined key_agrif 
    168             CALL Agrif_Step( stp )           ! AGRIF: time stepping 
     172            CALL stp                         ! AGRIF: time stepping 
    169173#else 
    170174            CALL stp( istp )                 ! standard time stepping 
    … …  
    195199      ! 
    196200#if defined key_agrif 
    197       CALL Agrif_ParentGrid_To_ChildGrid() 
    198       IF( lk_diaobs ) CALL dia_obs_wri 
    199       IF( nn_timing == 1 )   CALL timing_finalize 
    200       CALL Agrif_ChildGrid_To_ParentGrid() 
     201      IF( .NOT. Agrif_Root() ) THEN 
     202         CALL Agrif_ParentGrid_To_ChildGrid() 
     203         IF( lk_diaobs ) CALL dia_obs_wri 
     204         IF( nn_timing == 1 )   CALL timing_finalize 
     205         CALL Agrif_ChildGrid_To_ParentGrid() 
     206      ENDIF 
    201207#endif 
    202208      IF( nn_timing == 1 )   CALL timing_finalize 
    … …  
    342348         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    343349#endif 
    344       ENDIF 
     350      ENDIF          
    345351         jpk = jpkdta                                             ! third dim 
     352#if defined key_agrif 
     353         ! simple trick to use same vertical grid as parent 
     354         ! but different number of levels:  
     355         ! Save maximum number of levels in jpkdta, then define all vertical grids 
     356         ! with this number. 
     357         ! Suppress once vertical online interpolation is ok 
     358         IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 
     359#endif 
    346360         jpim1 = jpi-1                                            ! inner domain indices 
    347361         jpjm1 = jpj-1                                            !   "           " 
    … …  
    438452      IF( lk_trabbl     )   CALL tra_bbl_init   ! advective (and/or diffusive) bottom boundary layer scheme 
    439453      ! 
    440       IF( ln_crs_top .AND. lk_trabbl     )  THEN 
    441                             CALL dom_grid_crs  
    442                             CALL tra_bbl_init_crs   ! advective (and/or diffusive) bottom boundary layer scheme 
    443                             CALL dom_grid_glo 
    444       ENDIF 
     454      !cbr IF( ln_crs_top .AND. lk_trabbl     )  THEN 
     455      !                      CALL dom_grid_crs  
     456      !                      CALL tra_bbl_init_crs   ! advective (and/or diffusive) bottom boundary layer scheme 
     457      !                      CALL dom_grid_glo 
     458      !ENDIF 
    445459      ! 
    446460                            CALL tra_dmp_init   ! internal damping trends- tracers 
    … …  
    468482      IF( ln_crs_top )      CALL dom_grid_crs 
    469483                            CALL     trc_init 
    470                             CALL ldf_tra_crs_init 
     484      IF( ln_crs_top )      CALL ldf_tra_crs_init 
    471485      IF( ln_crs_top )      CALL dom_grid_glo 
    472486#endif 
    … …  
    735749      INTEGER :: ifac, jl, inu 
    736750      INTEGER, PARAMETER :: ntest = 14 
    737       INTEGER :: ilfax(ntest) 
    738       ! 
    739       ! lfax contains the set of allowed factors. 
    740       data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
    741          &                            128,   64,   32,   16,    8,   4,   2  / 
    742       !!---------------------------------------------------------------------- 
     751      INTEGER, DIMENSION(ntest) :: ilfax 
     752      ! 
     753      ! ilfax contains the set of allowed factors. 
     754      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
     755      !!---------------------------------------------------------------------- 
     756      ! ilfax contains the set of allowed factors. 
     757      ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    743758 
    744759      ! Clear the error flag and initialise output vars 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step.F90

    r7217 r7256  
    5151 
    5252#if defined key_agrif 
    53    SUBROUTINE stp( ) 
     53   RECURSIVE SUBROUTINE stp( ) 
    5454      INTEGER             ::   kstp   ! ocean time-step index 
    5555#else 
    … …  
    8282#if defined key_agrif 
    8383      kstp = nit000 + Agrif_Nb_Step() 
    84 !      IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
    85 !      IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 
     84      IF ( lk_agrif_debug ) THEN 
     85         IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
     86         IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 
     87      ENDIF 
     88 
    8689      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
     90 
    8791# if defined key_iomput 
    8892      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    … …  
    113117      ! Update stochastic parameters and random T/S fluctuations 
    114118      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    115                         CALL sto_par( kstp )          ! Stochastic parameters 
     119       IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters 
     120       IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations 
    116121 
    117122      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    155160      ! 
    156161      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
    157          IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    158162                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    159163         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    191195          ! Note that the computation of vertical velocity above, hence "after" sea level 
    192196          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
    193             IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    194197                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    195198            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    203206                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    204207                                  va(:,:,:) = 0.e0 
    205           IF(  ln_asmiau .AND. & 
     208          IF(  lk_asminc .AND. ln_asmiau .AND. & 
    206209             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
    207210          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
    … …  
    277280                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    278281 
    279       IF(  ln_asmiau .AND. & 
     282      IF(  lk_asminc .AND. ln_asmiau .AND. & 
    280283         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    281284                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    … …  
    299302         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    300303                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
    301             IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    302304                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    303305            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
    … …  
    310312      ELSE                                                  ! centered hpg  (eos then time stepping) 
    311313         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
    312             IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    313314                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    314315         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
    … …  
    343344                               va(:,:,:) = 0.e0 
    344345 
    345         IF(  ln_asmiau .AND. & 
     346        IF(  lk_asminc .AND. ln_asmiau .AND. & 
    346347           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    347348        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
    … …  
    364365                               CALL ssh_swp( kstp )         ! swap of sea surface height 
    365366      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    366  
     367      ! 
    367368      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    368       IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    369  
    370       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    371       ! Control and restarts 
     369 
     370      IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
     371      IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
     372 
     373#if defined key_agrif 
     374      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     375      ! AGRIF 
     376      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
     377                               CALL Agrif_Integrate_ChildGrids( stp )   
     378 
     379      IF ( Agrif_NbStepint().EQ.0 ) THEN 
     380                               CALL Agrif_Update_Tra()      ! Update active tracers 
     381                               CALL Agrif_Update_Dyn()      ! Update momentum 
     382      ENDIF 
     383#endif 
     384      IF( lk_diaobs        )   CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
     385 
     386      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
     387      ! Control 
    372388      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    373389                               CALL stp_ctl( kstp, indic ) 
    … …  
    381397         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    382398      ENDIF 
    383       IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
    384399 
    385400      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    396411      ! 
    397412      IF( nn_timing == 1 .AND.  kstp == nit000  )   CALL timing_reset 
     413      !      
    398414      ! 
    399415   END SUBROUTINE stp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r6772 r7256  
    117117#if defined key_agrif 
    118118   USE agrif_opa_sponge ! Momemtum and tracers sponges 
     119   USE agrif_opa_update ! Update (2-way nesting) 
    119120#endif 
    120121#if defined key_top 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r6101 r7256  
    1717   USE dom_oce         ! ocean space and time domain variables  
    1818   USE sol_oce         ! ocean space and time domain variables  
     19   USE sbc_oce         ! surface boundary conditions variables 
    1920   USE in_out_manager  ! I/O manager 
    2021   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    2223   USE dynspg_oce      ! pressure gradient schemes  
    2324   USE c1d             ! 1D vertical configuration 
     25 
    2426 
    2527   IMPLICIT NONE 
    … …  
    5254      INTEGER, INTENT( inout ) ::   kindic  ! indicator of solver convergence 
    5355      !! 
     56      CHARACTER(len = 32) ::        clfname ! time stepping output file name 
    5457      INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    5558      INTEGER  ::   ii, ij, ik              ! temporary integers 
    … …  
    6366         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6467         WRITE(numout,*) '~~~~~~~' 
    65          ! open time.step file 
    66          CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     68         ! open time.step file with special treatment for SAS 
     69         IF ( nn_components == jp_iam_sas ) THEN 
     70            clfname = 'time.step.sas' 
     71         ELSE 
     72            clfname = 'time.step' 
     73         ENDIF 
     74         CALL ctl_opn( numstp, TRIM(clfname), 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    6775      ENDIF 
    6876 
    … …  
    136144            WRITE(numout,*) '          output of last fields in numwso' 
    137145         ENDIF 
    138          WHERE( tsn(:,:,:,jp_sal) .LE. 0. )  tsn(:,:,:,jp_sal) = 0.1 
     146         kindic = -3 
    139147      ENDIF 
    1401489500  FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/SAS_SRC/daymod.F90

    r5602 r7256  
    7171      !!---------------------------------------------------------------------- 
    7272      ! 
     73      ! max number of seconds between each restart 
     74      IF( REAL( nitend - nit000 + 1 ) * rdt > REAL( HUGE( nsec1jan000 ) ) ) THEN 
     75         CALL ctl_stop( 'The number of seconds between each restart exceeds the integer 4 max value: 2^31-1. ',   & 
     76            &           'You must do a restart at higher frequency (or remove this stop and recompile the code in I8)' ) 
     77      ENDIF 
    7378      ! all calendar staff is based on the fact that MOD( rday, rdttra(1) ) == 0 
    7479      IF( MOD( rday     , rdttra(1) ) /= 0. )   CALL ctl_stop( 'the time step must devide the number of second of in a day' ) 
    … …  
    239244               nday_year = 1 
    240245               nsec_year = ndt05 
    241                IF( nsec1jan000 >= 2 * (2**30 - nsecd * nyear_len(1) / 2 ) ) THEN   ! test integer 4 max value 
    242                   CALL ctl_stop( 'The number of seconds between Jan. 1st 00h of nit000 year and Jan. 1st 00h ',   & 
    243                      &           'of the current year is exceeding the INTEGER 4 max VALUE: 2^31-1 -> 68.09 years in seconds', & 
    244                      & 'You must do a restart at higher frequency (or remove this STOP and recompile everything in I8)' ) 
    245                ENDIF 
    246246               nsec1jan000 = nsec1jan000 + nsecd * nyear_len(1) 
    247247               IF( nleapy == 1 )   CALL day_mth 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

    r5602 r7256  
    521521#endif 
    522522      ! 
    523       INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6 
     523      INTEGER :: ierr,ierr1,ierr2,ierr3,ierr4,ierr5,ierr6,ierr7,ierr8 
    524524      INTEGER :: jpm 
    525525      !!---------------------------------------------------------------------- 
    … …  
    545545      ALLOCATE( tsb(jpi,jpj,1,jpm)  , STAT=ierr5 ) 
    546546      ALLOCATE( sshn(jpi,jpj)       , STAT=ierr6 ) 
    547       ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6  
     547      ALLOCATE( un(jpi,jpj,1)       , STAT=ierr7 ) 
     548      ALLOCATE( vn(jpi,jpj,1)       , STAT=ierr8 ) 
     549      ierr = ierr + ierr1 + ierr2 + ierr3 + ierr4 + ierr5 + ierr6  + ierr7 + ierr8 
    548550#endif 
    549551      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zbio.F90

    r5602 r7256  
    599599 
    600600   !!====================================================================== 
    601 END MODULE  p2zbio 
     601END MODULE p2zbio 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsms.F90

    r5602 r7256  
    8484 
    8585   !!====================================================================== 
    86 END MODULE  p2zsms 
     86END MODULE p2zsms 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90

    r5602 r7256  
    109109 
    110110   !!====================================================================== 
    111 END MODULE  p4zbio 
    112  
     111END MODULE p4zbio 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90

    r5602 r7256  
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   fekeq    ! chemistry of Fe 
    3333   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemc    ! Solubilities of O2 and CO2 
    34    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2    ! Solubilities of O2 and CO2 
     34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2   ! Solubilities of O2 and CO2 
     35   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tempis   ! In situ temperature 
    3536 
    3637   REAL(wp), PUBLIC ::   atcox  = 0.20946         ! units atm 
    … …  
    3940   REAL(wp) ::   o2atm  = 1. / ( 1000. * 0.20946 )   
    4041 
    41    REAL(wp) ::   akcc1  = -171.9065       ! coeff. for apparent solubility equilibrium 
    42    REAL(wp) ::   akcc2  =   -0.077993     ! Millero et al. 1995 from Mucci 1983 
    43    REAL(wp) ::   akcc3  = 2839.319         
    44    REAL(wp) ::   akcc4  =   71.595         
    45    REAL(wp) ::   akcc5  =   -0.77712       
    46    REAL(wp) ::   akcc6  =    0.00284263    
    47    REAL(wp) ::   akcc7  =  178.34         
    48    REAL(wp) ::   akcc8  =   -0.07711      
    49    REAL(wp) ::   akcc9  =    0.0041249    
    50  
    51    REAL(wp) ::   rgas   = 83.143         ! universal gas constants 
     42   REAL(wp) ::   rgas   = 83.14472       ! universal gas constants 
    5243   REAL(wp) ::   oxyco  = 1. / 22.4144   ! converts from liters of an ideal gas to moles 
    5344 
    … …  
    5546   REAL(wp) ::   bor2   = 1. / 10.82 
    5647 
    57    REAL(wp) ::   ca0    = -162.8301      ! WEISS & PRICE 1980, units mol/(kg atm) 
    58    REAL(wp) ::   ca1    =  218.2968 
    59    REAL(wp) ::   ca2    =   90.9241 
    60    REAL(wp) ::   ca3    =   -1.47696 
    61    REAL(wp) ::   ca4    =    0.025695 
    62    REAL(wp) ::   ca5    =   -0.025225 
    63    REAL(wp) ::   ca6    =    0.0049867 
    64  
    65    REAL(wp) ::   c10    = -3670.7        ! Coeff. for 1. dissoc. of carbonic acid (Edmond and Gieskes, 1970)    
    66    REAL(wp) ::   c11    =    62.008      
    67    REAL(wp) ::   c12    =    -9.7944     
    68    REAL(wp) ::   c13    =     0.0118      
    69    REAL(wp) ::   c14    =    -0.000116 
    70  
    71    REAL(wp) ::   c20    = -1394.7       ! coeff. for 2. dissoc. of carbonic acid (Millero, 1995)    
    72    REAL(wp) ::   c21    =    -4.777    
    73    REAL(wp) ::   c22    =     0.0184    
    74    REAL(wp) ::   c23    =    -0.000118 
    75  
    7648   REAL(wp) ::   st1    =      0.14     ! constants for calculate concentrations for sulfate 
    7749   REAL(wp) ::   st2    =  1./96.062    !  (Morris & Riley 1966) 
    78    REAL(wp) ::   ks0    =    141.328  
    79    REAL(wp) ::   ks1    =  -4276.1   
    80    REAL(wp) ::   ks2    =    -23.093 
    81    REAL(wp) ::   ks3    = -13856.   
    82    REAL(wp) ::   ks4    =   324.57  
    83    REAL(wp) ::   ks5    =   -47.986 
    84    REAL(wp) ::   ks6    =  35474.  
    85    REAL(wp) ::   ks7    =   -771.54 
    86    REAL(wp) ::   ks8    =    114.723 
    87    REAL(wp) ::   ks9    =  -2698.   
    88    REAL(wp) ::   ks10   =   1776.  
    89    REAL(wp) ::   ks11   =      1. 
    90    REAL(wp) ::   ks12   =     -0.001005  
    9150 
    9251   REAL(wp) ::   ft1    =    0.000067   ! constants for calculate concentrations for fluorides 
    9352   REAL(wp) ::   ft2    = 1./18.9984    ! (Dickson & Riley 1979 ) 
    94    REAL(wp) ::   kf0    =  -12.641     
    95    REAL(wp) ::   kf1    = 1590.2     
    96    REAL(wp) ::   kf2    =    1.525     
    97    REAL(wp) ::   kf3    =    1.0      
    98    REAL(wp) ::   kf4    =   -0.001005 
    99  
    100    REAL(wp) ::   cb0    = -8966.90      ! Coeff. for 1. dissoc. of boric acid  
    101    REAL(wp) ::   cb1    = -2890.53      ! (Dickson and Goyet, 1994) 
    102    REAL(wp) ::   cb2    =   -77.942 
    103    REAL(wp) ::   cb3    =     1.728 
    104    REAL(wp) ::   cb4    =    -0.0996 
    105    REAL(wp) ::   cb5    =   148.0248 
    106    REAL(wp) ::   cb6    =   137.1942 
    107    REAL(wp) ::   cb7    =     1.62142 
    108    REAL(wp) ::   cb8    =   -24.4344 
    109    REAL(wp) ::   cb9    =   -25.085 
    110    REAL(wp) ::   cb10   =    -0.2474  
    111    REAL(wp) ::   cb11   =     0.053105 
    112  
    113    REAL(wp) ::   cw0    = -13847.26     ! Coeff. for dissoc. of water (Dickson and Riley, 1979 ) 
    114    REAL(wp) ::   cw1    =    148.9652   
    115    REAL(wp) ::   cw2    =    -23.6521 
    116    REAL(wp) ::   cw3    =    118.67  
    117    REAL(wp) ::   cw4    =     -5.977  
    118    REAL(wp) ::   cw5    =      1.0495   
    119    REAL(wp) ::   cw6    =     -0.01615 
    12053 
    12154   !                                    ! volumetric solubility constants for o2 in ml/L   
    … …  
    185118      REAL(wp) ::   ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 
    186119      REAL(wp) ::   zpres, ztc  , zcl   , zcpexp, zoxy  , zcpexp2 
    187       REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1 
    188       REAL(wp) ::   zis  , zis2 , zsal15, zisqrt 
     120      REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1, zc1, zplat 
     121      REAL(wp) ::   zis  , zis2 , zsal15, zisqrt, za1  , za2 
    189122      REAL(wp) ::   zckb , zck1 , zck2  , zckw  , zak1 , zak2  , zakb , zaksp0, zakw 
    190123      REAL(wp) ::   zst  , zft  , zcks  , zckf  , zaksp1 
    … …  
    193126      IF( nn_timing == 1 )  CALL timing_start('p4z_che') 
    194127      ! 
     128      ! Computations of chemical constants require in situ temperature 
     129      ! Here a quite simple formulation is used to convert  
     130      ! potential temperature to in situ temperature. The errors is less than  
     131      ! 0.04°C relative to an exact computation 
     132      ! --------------------------------------------------------------------- 
     133      DO jk = 1, jpk 
     134         DO jj = 1, jpj 
     135            DO ji = 1, jpi 
     136               zpres = fsdept(ji,jj,jk) / 1000. 
     137               za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (tsn(ji,jj,jk,jp_sal) - 35.0) ) 
     138               za2 = 0.0075 * ( 1.0 - tsn(ji,jj,jk,jp_tem) / 30.0 ) 
     139               tempis(ji,jj,jk) = tsn(ji,jj,jk,jp_tem) - za1 * zpres + za2 * zpres**2 
     140            END DO 
     141         END DO 
     142      END DO 
     143      ! 
    195144      ! CHEMICAL CONSTANTS - SURFACE LAYER 
    196145      ! ---------------------------------- 
    … …  
    200149         DO ji = 1, jpi 
    201150            !                             ! SET ABSOLUTE TEMPERATURE 
    202             ztkel = tsn(ji,jj,1,jp_tem) + 273.16 
     151            ztkel = tempis(ji,jj,1) + 273.15 
    203152            zt    = ztkel * 0.01 
    204153            zt2   = zt * zt 
    … …  
    208157            !                             ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 
    209158            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    210             zcek1 = ca0 + ca1 / zt + ca2 * zlogt + ca3 * zt2 + zsal * ( ca4 + ca5 * zt + ca6 * zt2 ) 
    211             !                             ! LN(K0) OF SOLUBILITY OF O2 and N2 in ml/L (EQ. 8, GARCIA AND GORDON, 1992) 
    212             ztgg  = LOG( ( 298.15 - tsn(ji,jj,1,jp_tem) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
    213             ztgg2 = ztgg  * ztgg 
    214             ztgg3 = ztgg2 * ztgg 
    215             ztgg4 = ztgg3 * ztgg 
    216             ztgg5 = ztgg4 * ztgg 
    217             zoxy  = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5   & 
    218                    + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) +  ox10 * zsal2 
    219  
     159            zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel    & 
     160            &       + 0.0047036e-4*ztkel**2) 
    220161            !                             ! SET SOLUBILITIES OF O2 AND CO2  
    221             chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
    222             chemc(ji,jj,2) = ( EXP( zoxy  ) * o2atm ) * oxyco              ! mol/(L atm) 
     162            chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(kg uatm) 
     163            chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 
     164            chemc(ji,jj,3) = 57.7 - 0.118*ztkel 
    223165            ! 
    224166         END DO 
    … …  
    233175!CDIR NOVERRCHK 
    234176            DO ji = 1, jpi 
    235               ztkel = tsn(ji,jj,jk,jp_tem) + 273.16 
     177              ztkel = tempis(ji,jj,jk) + 273.15 
    236178              zsal  = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 
    237179              zsal2 = zsal * zsal 
    238               ztgg  = LOG( ( 298.15 - tsn(ji,jj,jk,jp_tem) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
     180              ztgg  = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
    239181              ztgg2 = ztgg  * ztgg 
    240182              ztgg3 = ztgg2 * ztgg 
    … …  
    259201            DO ji = 1, jpi 
    260202 
    261                ! SET PRESSION 
    262                zpres   = 1.025e-1 * fsdept(ji,jj,jk) 
     203               ! SET PRESSION ACCORDING TO SAUNDER (1980) 
     204               zplat   = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) ) 
     205               zc1 = 5.92E-3 + zplat**2 * 5.25E-3 
     206               zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*fsdept(ji,jj,jk)))) / 4.42E-6 
     207               zpres = zpres / 10.0 
    263208 
    264209               ! SET ABSOLUTE TEMPERATURE 
    265                ztkel   = tsn(ji,jj,jk,jp_tem) + 273.16 
     210               ztkel   = tempis(ji,jj,jk) + 273.15 
    266211               zsal    = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 
    267212               zsqrt  = SQRT( zsal ) 
    … …  
    272217               zis2   = zis * zis 
    273218               zisqrt = SQRT( zis ) 
    274                ztc     = tsn(ji,jj,jk,jp_tem) + ( 1.- tmask(ji,jj,jk) ) * 20. 
     219               ztc     = tempis(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. 
    275220 
    276221               ! CHLORINITY (WOOSTER ET AL., 1969) 
    … …  
    284229 
    285230               ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 
    286                zcks    = EXP(  ks1 * ztr + ks0 + ks2 * zlogt                           & 
    287                   &                     + ( ks3 * ztr + ks4 + ks5 * zlogt ) * zisqrt   & 
    288                   &                     + ( ks6 * ztr + ks7 + ks8 * zlogt ) * zis      & 
    289                   &                     + ks9 * ztr * zis * zisqrt + ks10 * ztr *zis2 + LOG( ks11 + ks12 *zsal )  ) 
     231               zcks    = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt         & 
     232               &         + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 
     233               &         + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis    & 
     234               &         - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2         & 
     235               &         + LOG(1.0 - 0.001005 * zsal)) 
     236               ! 
     237               aphscale(ji,jj,jk) = ( 1. + zst / zcks ) 
    290238 
    291239               ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 
    292                zckf    = EXP(  kf1 * ztr + kf0 + kf2 * zisqrt + LOG( kf3 + kf4 * zsal )  ) 
     240               zckf    = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt   & 
     241               &         + LOG(1.0d0 - 0.001005d0*zsal)            & 
     242               &         + LOG(1.0d0 + zst/zcks)) 
    293243 
    294244               ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 
    295                zckb    = ( cb0 + cb1 * zsqrt + cb2  * zsal + cb3 * zsal15 + cb4 * zsal * zsal ) * ztr   & 
    296                   &    + ( cb5 + cb6 * zsqrt + cb7  * zsal )                                            & 
    297                   &    + ( cb8 + cb9 * zsqrt + cb10 * zsal ) * zlogt + cb11 * zsqrt * ztkel             & 
    298                   &    + LOG(  ( 1.+ zst / zcks + zft / zckf ) / ( 1.+ zst / zcks )  ) 
    299  
    300                zck1    = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal * zsal 
    301                zck2    = c20 * ztr + c21 + c22 * zsal   + c23 * zsal**2 
     245               zckb=  (-8966.90 - 2890.53*zsqrt - 77.942*zsal        & 
     246               &      + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr         & 
     247               &      + (148.0248 + 137.1942*zsqrt + 1.62142*zsal)   & 
     248               &      + (-24.4344 - 25.085*zsqrt - 0.2474*zsal)      &  
     249               &      * zlogt + 0.053105*zsqrt*ztkel 
     250 
     251 
     252               ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO  
     253               ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale 
     254               zck1    = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt  & 
     255                  - 0.011555*zsal + 0.0001152*zsal*zsal) 
     256               zck2    = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt      & 
     257                  - 0.01781*zsal + 0.0001122*zsal*zsal) 
    302258 
    303259               ! PKW (H2O) (DICKSON AND RILEY, 1979) 
    304                zckw    = cw0 * ztr + cw1 + cw2 * zlogt + ( cw3 * ztr + cw4 + cw5 * zlogt ) * zsqrt + cw6 * zsal 
    305  
     260               zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt    &  
     261               &     + (118.67*ztr - 5.977 + 1.0495 * zlogt)        & 
     262               &     * zsqrt - 0.01615 * zsal 
    306263 
    307264               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    308265               !       (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) 
    309                zaksp0  = akcc1 + akcc2 * ztkel + akcc3 * ztr + akcc4 * LOG10( ztkel )   & 
    310                   &   + ( akcc5 + akcc6 * ztkel + akcc7 * ztr ) * zsqrt + akcc8 * zsal + akcc9 * zsal15 
     266               zaksp0  = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel )   & 
     267                  &      + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt  & 
     268                  &      - 0.07711*zsal + 0.0041249*zsal15 
    311269 
    312270               ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 
    … …  
    378336      !!                     ***  ROUTINE p4z_che_alloc  *** 
    379337      !!---------------------------------------------------------------------- 
    380       ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,2), chemo2(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
     338      ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk),   & 
     339      &         tempis(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
    381340      ! 
    382341      IF( p4z_che_alloc /= 0 )   CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') 
    … …  
    396355 
    397356   !!====================================================================== 
    398 END MODULE  p4zche 
     357END MODULE p4zche 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r5602 r7256  
    8484      ! 
    8585      INTEGER  ::   ji, jj, jm, iind, iindm1 
    86       REAL(wp) ::   ztc, ztc2, ztc3, zws, zkgwan 
     86      REAL(wp) ::   ztc, ztc2, ztc3, ztc4, zws, zkgwan 
    8787      REAL(wp) ::   zfld, zflu, zfld16, zflu16, zfact 
     88      REAL(wp) ::   zvapsw, zsal, zfco2, zxc2, xCO2approx, ztkel, zfugcoeff 
    8889      REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 
    8990      REAL(wp) ::   zyr_dec, zdco2dt 
    9091      CHARACTER (len=25) :: charout 
    91       REAL(wp), POINTER, DIMENSION(:,:) :: zkgco2, zkgo2, zh2co3, zoflx, zw2d  
     92      REAL(wp), POINTER, DIMENSION(:,:) :: zkgco2, zkgo2, zh2co3, zoflx, zw2d, zpco2atm  
    9293      !!--------------------------------------------------------------------- 
    9394      ! 
    9495      IF( nn_timing == 1 )  CALL timing_start('p4z_flx') 
    9596      ! 
    96       CALL wrk_alloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx ) 
     97      CALL wrk_alloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 
    9798      ! 
    9899 
    … …  
    135136 
    136137               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    137                zalk  = zalka - (  akw3(ji,jj,1) / zph - zph + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
     138               zalk  = zalka - (  akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1)    & 
     139               &       + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
    138140 
    139141               ! CALCULATE [H+] AND [H2CO3] 
    … …  
    162164            ztc2 = ztc * ztc 
    163165            ztc3 = ztc * ztc2  
     166            ztc4 = ztc2 * ztc2  
    164167            ! Compute the schmidt Number both O2 and CO2 
    165             zsch_co2 = 2073.1 - 125.62 * ztc + 3.6276 * ztc2 - 0.043126 * ztc3 
    166             zsch_o2  = 1953.4 - 128.0  * ztc + 3.9918 * ztc2 - 0.050091 * ztc3 
     168            zsch_co2 = 2116.8 - 136.25 * ztc + 4.7353 * ztc2 - 0.092307 * ztc3 + 0.0007555 * ztc4 
     169            zsch_o2  = 1920.4 - 135.6  * ztc + 5.2122 * ztc2 - 0.109390 * ztc3 + 0.0009377 * ztc4 
    167170            !  wind speed  
    168171            zws  = wndm(ji,jj) * wndm(ji,jj) 
    169172            ! Compute the piston velocity for O2 and CO2 
    170             zkgwan = 0.3 * zws  + 2.5 * ( 0.5246 + 0.016256 * ztc + 0.00049946  * ztc2 ) 
     173            zkgwan = 0.251 * zws 
    171174            zkgwan = zkgwan * xconv * ( 1.- fr_i(ji,jj) ) * tmask(ji,jj,1) 
    172175# if defined key_degrad 
    … …  
    181184      DO jj = 1, jpj 
    182185         DO ji = 1, jpi 
     186            ztkel  = tsn(ji,jj,1,jp_tem) + 273.15 
     187            zsal   = tsn(ji,jj,1,jp_sal) + ( 1.- tmask(ji,jj,1) ) * 35. 
     188            zvapsw = EXP(24.4543 - 67.4509*(100.0/ztkel) - 4.8489*LOG(ztkel/100) - 0.000544*zsal) 
     189            zpco2atm(ji,jj) = satmco2(ji,jj) * ( patm(ji,jj) - zvapsw ) 
     190            zxc2 = (1.0 - zpco2atm(ji,jj) * 1E-6 )**2 
     191            zfugcoeff = EXP(patm(ji,jj) * (chemc(ji,jj,2) + 2.0 * zxc2 * chemc(ji,jj,3) )   & 
     192            &           / (82.05736 * ztkel)) 
     193            zfco2 = zpco2atm(ji,jj) * zfugcoeff 
     194 
    183195            ! Compute CO2 flux for the sea and air 
    184             zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
    185             zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
     196            zfld = zfco2 * chemc(ji,jj,1) * zkgco2(ji,jj)  ! (mol/L) * (m/s) 
     197            zflu = zh2co3(ji,jj) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
    186198            oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
    187199            ! compute the trend 
    188             tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) * rfact2 / fse3t(ji,jj,1) 
     200            tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) * rfact2 / fse3t(ji,jj,1) * tmask(ji,jj,1) 
    189201 
    190202            ! Compute O2 flux  
    191             zfld16 = atcox * patm(ji,jj) * chemc(ji,jj,2) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
    192             zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
    193             zoflx(ji,jj) = zfld16 - zflu16 
     203            zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
     204            zflu16 = trb(ji,jj,1,jpoxy) * zkgo2(ji,jj) 
     205            zoflx(ji,jj) = ( zfld16 - zflu16 ) * tmask(ji,jj,1) 
    194206            tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zoflx(ji,jj) * rfact2 / fse3t(ji,jj,1) 
    195207         END DO 
    … …  
    222234         ENDIF 
    223235         IF( iom_use( "Dpco2" ) ) THEN 
    224            zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
     236           zw2d(:,:) = ( zpco2atm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
    225237           CALL iom_put( "Dpco2" ,  zw2d ) 
    226238         ENDIF 
    227239         IF( iom_use( "Dpo2" ) )  THEN 
    228            zw2d(:,:) = ( atcox * patm(:,:) - trb(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1) 
     240           zw2d(:,:) = ( atcox * patm(:,:) - atcox * trn(:,:,1,jpoxy) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) 
    229241           CALL iom_put( "Dpo2"  , zw2d ) 
    230242         ENDIF 
    … …  
    238250            trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)  
    239251            trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)  
    240             trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1)  
    241          ENDIF 
    242       ENDIF 
    243       ! 
    244       CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx ) 
     252            trc2d(:,:,jp_pcs0_2d + 3) = ( zpco2atm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
     253         ENDIF 
     254      ENDIF 
     255      ! 
     256      CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 
    245257      ! 
    246258      IF( nn_timing == 1 )  CALL timing_stop('p4z_flx') 
    … …  
    400412 
    401413   !!====================================================================== 
    402 END MODULE  p4zflx 
     414END MODULE p4zflx 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zint.F90

    r5602 r7256  
    8181 
    8282   !!====================================================================== 
    83 END MODULE  p4zint 
     83END MODULE p4zint 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90

    r5602 r7256  
    4444   REAL(wp), PUBLIC ::  xkdoc       !:  2nd half-sat. of DOC remineralization   
    4545   REAL(wp), PUBLIC ::  concbfe     !:  Fe half saturation for bacteria  
     46   REAL(wp), PUBLIC ::  oxymin      !:  half saturation constant for anoxia 
    4647   REAL(wp), PUBLIC ::  qnfelim     !:  optimal Fe quota for nanophyto 
    4748   REAL(wp), PUBLIC ::  qdfelim     !:  optimal Fe quota for diatoms 
    … …  
    121122               zlim1    = xnanono3(ji,jj,jk) + xnanonh4(ji,jj,jk) 
    122123               zlim2    = trb(ji,jj,jk,jppo4) / ( trb(ji,jj,jk,jppo4) + concbnh4 ) 
    123                zlim3    = trb(ji,jj,jk,jpfer) / ( concbfe + trb(ji,jj,jk,jpfer) ) 
     124               zlim3    = biron(ji,jj,jk)     / ( concbfe + biron(ji,jj,jk) ) 
    124125               zlim4    = trb(ji,jj,jk,jpdoc) / ( xkdoc   + trb(ji,jj,jk,jpdoc) ) 
    125126               xlimbacl(ji,jj,jk) = MIN( zlim1, zlim2, zlim3 ) 
    … …  
    187188      END DO 
    188189      ! 
     190      DO jk = 1, jpkm1 
     191         DO jj = 1, jpj 
     192            DO ji = 1, jpi 
     193               ! denitrification factor computed from O2 levels 
     194               nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    & 
     195                  &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  ) 
     196               nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) ) 
     197            END DO 
     198         END DO 
     199      END DO 
    189200      ! 
    190201      IF( lk_iomput .AND. knt == nrdttrc ) THEN        ! save output diagnostics 
    … …  
    216227      NAMELIST/nampislim/ concnno3, concdno3, concnnh4, concdnh4, concnfer, concdfer, concbfe,   & 
    217228         &                concbno3, concbnh4, xsizedia, xsizephy, xsizern, xsizerd,          &  
    218          &                xksi1, xksi2, xkdoc, qnfelim, qdfelim, caco3r 
     229         &                xksi1, xksi2, xkdoc, qnfelim, qdfelim, caco3r, oxymin 
    219230      INTEGER :: ios                 ! Local integer output status for namelist read 
    220231 
    … …  
    249260         WRITE(numout,*) '    Minimum size criteria for nanophyto      xsizephy  = ', xsizephy 
    250261         WRITE(numout,*) '    Fe half saturation for bacteria          concbfe   = ', concbfe 
     262         WRITE(numout,*) '    halk saturation constant for anoxia       oxymin   =' , oxymin 
    251263         WRITE(numout,*) '    optimal Fe quota for nano.               qnfelim   = ', qnfelim 
    252264         WRITE(numout,*) '    Optimal Fe quota for diatoms             qdfelim   = ', qdfelim 
    253265      ENDIF 
    254  
     266      ! 
     267      nitrfac (:,:,:) = 0._wp 
     268      ! 
    255269   END SUBROUTINE p4z_lim_init 
    256270 
    … …  
    265279 
    266280   !!====================================================================== 
    267 END MODULE  p4zlim 
     281END MODULE p4zlim 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90

    r5602 r7256  
    6565      REAL(wp) ::   zomegaca, zexcess, zexcess0 
    6666      CHARACTER (len=25) :: charout 
    67       REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zcaldiss    
     67      REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss    
    6868      !!--------------------------------------------------------------------- 
    6969      ! 
    7070      IF( nn_timing == 1 )  CALL timing_start('p4z_lys') 
    7171      ! 
    72       CALL wrk_alloc( jpi, jpj, jpk, zco3, zcaldiss ) 
     72      CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
    7373      ! 
    7474      zco3    (:,:,:) = 0. 
    … …  
    9191                  zalka = trb(ji,jj,jk,jptal) / zfact 
    9292                  ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    93                   zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
     93                  zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn )  & 
     94                  &       + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
    9495                  ! CALCULATE [H+] and [CO3--] 
    9596                  zaldi = zdic - zalk 
    … …  
    119120               zcalcon  = calcon * ( tsn(ji,jj,jk,jp_sal) / 35._wp ) 
    120121               zfact    = rhop(ji,jj,jk) / 1000._wp 
    121                zomegaca = ( zcalcon * zco3(ji,jj,jk) * zfact ) / aksp(ji,jj,jk)  
     122               zomegaca = ( zcalcon * zco3(ji,jj,jk) ) / ( aksp(ji,jj,jk) * zfact + rtrn ) 
     123               zco3sat(ji,jj,jk) = aksp(ji,jj,jk) * zfact / ( zcalcon + rtrn ) 
    122124 
    123125               ! SET DEGREE OF UNDER-/SUPERSATURATION 
    … …  
    148150      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    149151         IF( iom_use( "PH"     ) ) CALL iom_put( "PH"    , -1. * LOG10( hi(:,:,:) )          * tmask(:,:,:) ) 
    150          IF( iom_use( "CO3"    ) ) CALL iom_put( "CO3"   , zco3(:,:,:) * 1.e+3               * tmask(:,:,:) ) 
    151          IF( iom_use( "CO3sat" ) ) CALL iom_put( "CO3sat", aksp(:,:,:) * 1.e+3 / calcon      * tmask(:,:,:) ) 
    152          IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r   * tmask(:,:,:) ) 
     152         IF( iom_use( "CO3"    ) ) CALL iom_put( "CO3"   , zco3(:,:,:)    * 1.e+3            * tmask(:,:,:) ) 
     153         IF( iom_use( "CO3sat" ) ) CALL iom_put( "CO3sat", zco3sat(:,:,:) * 1.e+3            * tmask(:,:,:) ) 
     154         IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) 
    153155      ELSE 
    154          trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
    155          trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
    156          trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
     156         IF( ln_diatrc ) THEN 
     157            trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
     158            trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
     159            trc3d(:,:,:,jp_pcs0_3d + 2) = zco3sat(:,:,:)           * tmask(:,:,:) 
     160         ENDIF 
    157161      ENDIF 
    158162      ! 
    … …  
    163167      ENDIF 
    164168      ! 
    165       CALL wrk_dealloc( jpi, jpj, jpk, zco3, zcaldiss ) 
     169      CALL wrk_dealloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
    166170      ! 
    167171      IF( nn_timing == 1 )  CALL timing_stop('p4z_lys') 
    … …  
    223227#endif  
    224228   !!====================================================================== 
    225 END MODULE  p4zlys 
     229END MODULE p4zlys 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmeso.F90

    r5602 r7256  
    340340 
    341341   !!====================================================================== 
    342 END MODULE  p4zmeso 
     342END MODULE p4zmeso 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90

    r5602 r7256  
    273273 
    274274   !!====================================================================== 
    275 END MODULE  p4zmicro 
     275END MODULE p4zmicro 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90

    r5602 r7256  
    277277 
    278278   !!====================================================================== 
    279 END MODULE  p4zmort 
     279END MODULE p4zmort 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

    r5602 r7256  
    7676      REAL(wp) ::   zchl 
    7777      REAL(wp) ::   zc0 , zc1 , zc2, zc3, z1_dep 
    78       REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4, zqsr100 
     78      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 
     79      REAL(wp), POINTER, DIMENSION(:,:  ) :: zqsr100, zqsr_corr 
    7980      REAL(wp), POINTER, DIMENSION(:,:,:) :: zpar, ze0, ze1, ze2, ze3 
    8081      !!--------------------------------------------------------------------- 
    … …  
    8384      ! 
    8485      ! Allocate temporary workspace 
    85       CALL wrk_alloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     86      CALL wrk_alloc( jpi, jpj,      zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     87      CALL wrk_alloc( jpi, jpj,      zqsr100, zqsr_corr ) 
    8688      CALL wrk_alloc( jpi, jpj, jpk, zpar, ze0, ze1, ze2, ze3 ) 
    8789 
    … …  
    112114      !                                        !  -------------------------------------- 
    113115      IF( l_trcdm2dc ) THEN                     !  diurnal cycle 
    114          ! 1% of qsr to compute euphotic layer 
    115          zqsr100(:,:) = 0.01 * qsr_mean(:,:)     !  daily mean qsr 
    116          ! 
    117          CALL p4z_opt_par( kt, qsr_mean, ze1, ze2, ze3 )  
     116         ! 
     117         zqsr_corr(:,:) = qsr_mean(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     118         ! 
     119         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )  
    118120         ! 
    119121         DO jk = 1, nksrp       
    … …  
    123125         END DO 
    124126         ! 
    125          CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     127         zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     128         ! 
     129         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3 )  
    126130         ! 
    127131         DO jk = 1, nksrp       
    … …  
    130134         ! 
    131135      ELSE 
    132          ! 1% of qsr to compute euphotic layer 
    133          zqsr100(:,:) = 0.01 * qsr(:,:) 
    134          ! 
    135          CALL p4z_opt_par( kt, qsr, ze1, ze2, ze3 )  
     136         ! 
     137         zqsr_corr(:,:) = qsr(:,:) / ( 1. - fr_i(:,:) + rtrn ) 
     138         ! 
     139         CALL p4z_opt_par( kt, zqsr_corr, ze1, ze2, ze3, pqsr100 = zqsr100 )  
    136140         ! 
    137141         DO jk = 1, nksrp       
    … …  
    161165         DO jj = 1, jpj 
    162166           DO ji = 1, jpi 
    163               IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= 0.43 * zqsr100(ji,jj) )  THEN 
     167              IF( etot_ndcy(ji,jj,jk) * tmask(ji,jj,jk) >= zqsr100(ji,jj) )  THEN 
    164168                 neln(ji,jj) = jk+1                    ! Euphotic level : 1rst T-level strictly below Euphotic layer 
    165169                 !                                     ! nb: ensure the compatibility with nmld_trc definition in trd_mld_trc_zint 
    … …  
    226230      ENDIF 
    227231      ! 
    228       CALL wrk_dealloc( jpi, jpj,      zqsr100, zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     232      CALL wrk_dealloc( jpi, jpj,      zdepmoy, zetmp1, zetmp2, zetmp3, zetmp4 ) 
     233      CALL wrk_dealloc( jpi, jpj,      zqsr100, zqsr_corr ) 
    229234      CALL wrk_dealloc( jpi, jpj, jpk, zpar,  ze0, ze1, ze2, ze3 ) 
    230235      ! 
    … …  
    233238   END SUBROUTINE p4z_opt 
    234239 
    235    SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0 )  
     240   SUBROUTINE p4z_opt_par( kt, pqsr, pe1, pe2, pe3, pe0, pqsr100 )  
    236241      !!---------------------------------------------------------------------- 
    237242      !!                  ***  routine p4z_opt_par  *** 
    … …  
    242247      !!---------------------------------------------------------------------- 
    243248      !! * arguments 
    244       INTEGER, INTENT(in)                                       ::  kt            !   ocean time-step 
    245       REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in)              ::  pqsr          !   shortwave 
    246       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::  pe1 , pe2 , pe3   !  PAR ( R-G-B) 
    247       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL ::  pe0   
     249      INTEGER, INTENT(in)                                        ::  kt            !   ocean time-step 
     250      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(in)               ::  pqsr          !   shortwave 
     251      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)            ::  pe1 , pe2 , pe3   !  PAR ( R-G-B) 
     252      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout), OPTIONAL  ::  pe0  
     253      REAL(wp), DIMENSION(jpi,jpj)    , INTENT(out)  , OPTIONAL  ::  pqsr100   
    248254      !! * local variables 
    249255      INTEGER    ::   ji, jj, jk     ! dummy loop indices 
    … …  
    255261      ELSE                  ;  zqsr(:,:) = xparsw         * pqsr(:,:) 
    256262      ENDIF 
     263 
     264      !  Light at the euphotic depth  
     265      IF( PRESENT( pqsr100 ) )  pqsr100(:,:) = 0.01 * 3. * zqsr(:,:) 
    257266      ! 
    258267      IF( PRESENT( pe0 ) ) THEN     !  W-level 
    … …  
    439448 
    440449   !!====================================================================== 
    441 END MODULE  p4zopt 
     450END MODULE p4zopt 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90

    r5602 r7256  
    202202                      zdiattot    = ediat(ji,jj,jk) * zstrn(ji,jj) 
    203203                      ! 
    204                       zpislopead (ji,jj,jk) = pislope  * ( 1.+ zadap  * EXP( -znanotot ) ) 
    205                       zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp)  / ( trb(ji,jj,jk,jpdia) + rtrn ) 
    206  
    207                       zpislopen =  zpislopead(ji,jj,jk) * trb(ji,jj,jk,jpnch)                & 
    208                         &          / ( trb(ji,jj,jk,jpphy) * 12.                  + rtrn )   & 
    209                         &          / ( prmax(ji,jj,jk) * rday * xlimphy(ji,jj,jk) + rtrn ) 
    210  
    211                       zpislope2n = zpislopead2(ji,jj,jk) * trb(ji,jj,jk,jpdch)                & 
    212                         &          / ( trb(ji,jj,jk,jpdia) * 12.                  + rtrn )   & 
    213                         &          / ( prmax(ji,jj,jk) * rday * xlimdia(ji,jj,jk) + rtrn ) 
     204                      zpislopead (ji,jj,jk) = pislope  * ( 1.+ zadap  * EXP( -znanotot ) )           & 
     205                         &                   * trb(ji,jj,jk,jpnch) /( trb(ji,jj,jk,jpphy) * 12. + rtrn) 
     206                      zpislopead2(ji,jj,jk) = (pislope * zconctemp2 + pislope2 * zconctemp)  / ( trb(ji,jj,jk,jpdia) + rtrn )   & 
     207                         &                   * trb(ji,jj,jk,jpdch) /( trb(ji,jj,jk,jpdia) * 12. + rtrn) 
    214208 
    215209                      ! Computation of production function for Carbon 
    216210                      !  --------------------------------------------- 
     211                      zpislopen  =  zpislopead(ji,jj,jk)  / ( prmax(ji,jj,jk) * rday * xlimphy(ji,jj,jk) + rtrn ) 
     212                      zpislope2n =  zpislopead2(ji,jj,jk) / ( prmax(ji,jj,jk) * rday * xlimdia(ji,jj,jk) + rtrn ) 
    217213                      zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1.- EXP( -zpislopen  * znanotot ) ) 
    218214                      zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1.- EXP( -zpislope2n * zdiattot ) ) 
    … …  
    220216                      !  Computation of production function for Chlorophyll 
    221217                      !-------------------------------------------------- 
    222                       zprnch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislopen  * enano(ji,jj,jk) ) ) 
    223                       zprdch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislope2n * ediat(ji,jj,jk) ) ) 
     218                      zprnch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislopen  * znanotot ) ) 
     219                      zprdch(ji,jj,jk) = prmax(ji,jj,jk) * ( 1.- EXP( -zpislope2n * zdiattot ) ) 
    224220                  ENDIF 
    225221               END DO 
    … …  
    227223         END DO 
    228224      ENDIF 
    229  
    230  
     225       
    231226      !  Computation of a proxy of the N/C ratio 
    232227      !  --------------------------------------- 
    … …  
    278273            zmxltst = MAX( 0.e0, hmld(ji,jj) - heup(ji,jj) ) 
    279274            zmxlday = zmxltst * zmxltst * r1_rday 
    280             zmixnano(ji,jj) = 1. - zmxlday / ( 2. + zmxlday ) 
    281             zmixdiat(ji,jj) = 1. - zmxlday / ( 4. + zmxlday ) 
     275            zmixnano(ji,jj) = 1. - zmxlday / ( 1. + zmxlday ) 
     276            zmixdiat(ji,jj) = 1. - zmxlday / ( 2. + zmxlday ) 
    282277         END DO 
    283278      END DO 
    284279  
    285       !  Mixed-layer effect on production                                                                                
     280      !  Mixed-layer effect on production  
     281      !  Sea-ice effect on production 
     282 
    286283      DO jk = 1, jpkm1 
    287284         DO jj = 1, jpj 
    … …  
    291288                  zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * zmixdiat(ji,jj) 
    292289               ENDIF 
     290                  zprbio(ji,jj,jk) = zprbio(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) 
     291                  zprdia(ji,jj,jk) = zprdia(ji,jj,jk) * ( 1. - fr_i(ji,jj) ) 
    293292            END DO 
    294293         END DO 
    … …  
    330329      END DO 
    331330 
    332       IF( ln_newprod ) THEN 
    333 !CDIR NOVERRCHK 
    334          DO jk = 1, jpkm1 
    335 !CDIR NOVERRCHK 
    336             DO jj = 1, jpj 
    337 !CDIR NOVERRCHK 
    338                DO ji = 1, jpi 
    339                   IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
    340                      zprnch(ji,jj,jk) = zprnch(ji,jj,jk) * zmixnano(ji,jj) 
    341                      zprdch(ji,jj,jk) = zprdch(ji,jj,jk) * zmixdiat(ji,jj) 
    342                   ENDIF 
    343                   IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    344                      !  production terms for nanophyto. ( chlorophyll ) 
    345                      znanotot = enano(ji,jj,jk) * zstrn(ji,jj) 
    346                      zprod    = rday * zprorca(ji,jj,jk) * zprnch(ji,jj,jk) * xlimphy(ji,jj,jk) 
    347                      zprochln(ji,jj,jk) = chlcmin * 12. * zprorca (ji,jj,jk) 
    348                      zprochln(ji,jj,jk) = zprochln(ji,jj,jk) + (chlcnm-chlcmin) * 12. * zprod / & 
    349                                         & (  zpislopead(ji,jj,jk) * znanotot +rtrn) 
    350                      !  production terms for diatomees ( chlorophyll ) 
    351                      zdiattot = ediat(ji,jj,jk) * zstrn(ji,jj) 
    352                      zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * xlimdia(ji,jj,jk) 
    353                      zprochld(ji,jj,jk) = chlcmin * 12. * zprorcad(ji,jj,jk) 
    354                      zprochld(ji,jj,jk) = zprochld(ji,jj,jk) + (chlcdm-chlcmin) * 12. * zprod / & 
    355                                         & ( zpislopead2(ji,jj,jk) * zdiattot +rtrn ) 
    356                   ENDIF 
    357                END DO 
    358             END DO 
    359          END DO 
    360       ELSE 
    361 !CDIR NOVERRCHK 
    362          DO jk = 1, jpkm1 
    363 !CDIR NOVERRCHK 
    364             DO jj = 1, jpj 
    365 !CDIR NOVERRCHK 
    366                DO ji = 1, jpi 
    367                   IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
    368                      !  production terms for nanophyto. ( chlorophyll ) 
    369                      znanotot = enano(ji,jj,jk) 
    370                      zprod = rday * zprorca(ji,jj,jk) * zprnch(ji,jj,jk) * trb(ji,jj,jk,jpphy) * xlimphy(ji,jj,jk) 
    371                      zprochln(ji,jj,jk) = chlcmin * 12. * zprorca (ji,jj,jk) 
    372                      zprochln(ji,jj,jk) = zprochln(ji,jj,jk) + (chlcnm-chlcmin) * 144. * zprod            & 
    373                      &                    / ( zpislopead(ji,jj,jk) * trb(ji,jj,jk,jpnch) * znanotot +rtrn ) 
    374                      !  production terms for diatomees ( chlorophyll ) 
    375                      zdiattot = ediat(ji,jj,jk) 
    376                      zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * trb(ji,jj,jk,jpdia) * xlimdia(ji,jj,jk) 
    377                      zprochld(ji,jj,jk) = chlcmin * 12. * zprorcad(ji,jj,jk) 
    378                      zprochld(ji,jj,jk) = zprochld(ji,jj,jk) + (chlcdm-chlcmin) * 144. * zprod             & 
    379                      &                    / ( zpislopead2(ji,jj,jk) * trb(ji,jj,jk,jpdch) * zdiattot +rtrn ) 
    380                   ENDIF 
    381                END DO 
    382             END DO 
    383          END DO 
    384       ENDIF 
     331!CDIR NOVERRCHK 
     332      DO jk = 1, jpkm1 
     333!CDIR NOVERRCHK 
     334         DO jj = 1, jpj 
     335!CDIR NOVERRCHK 
     336            DO ji = 1, jpi 
     337               IF( fsdepw(ji,jj,jk+1) <= hmld(ji,jj) ) THEN 
     338                  zprnch(ji,jj,jk) = zprnch(ji,jj,jk) * zmixnano(ji,jj) 
     339                  zprdch(ji,jj,jk) = zprdch(ji,jj,jk) * zmixdiat(ji,jj) 
     340               ENDIF 
     341               IF( etot_ndcy(ji,jj,jk) > 1.E-3 ) THEN 
     342                  !  production terms for nanophyto. ( chlorophyll ) 
     343                  znanotot = enano(ji,jj,jk) * zstrn(ji,jj) 
     344                  zprod    = rday * zprorca(ji,jj,jk) * zprnch(ji,jj,jk) * xlimphy(ji,jj,jk) 
     345                  zprochln(ji,jj,jk) = chlcmin * 12. * zprorca (ji,jj,jk) 
     346                  zprochln(ji,jj,jk) = zprochln(ji,jj,jk) + (chlcnm-chlcmin) * 12. * zprod / & 
     347                                     & (  zpislopead(ji,jj,jk) * znanotot +rtrn) 
     348                  !  production terms for diatomees ( chlorophyll ) 
     349                  zdiattot = ediat(ji,jj,jk) * zstrn(ji,jj) 
     350                  zprod = rday * zprorcad(ji,jj,jk) * zprdch(ji,jj,jk) * xlimdia(ji,jj,jk) 
     351                  zprochld(ji,jj,jk) = chlcmin * 12. * zprorcad(ji,jj,jk) 
     352                  zprochld(ji,jj,jk) = zprochld(ji,jj,jk) + (chlcdm-chlcmin) * 12. * zprod / & 
     353                                     & ( zpislopead2(ji,jj,jk) * zdiattot +rtrn ) 
     354               ENDIF 
     355            END DO 
     356         END DO 
     357      END DO 
    385358 
    386359      !   Update the arrays TRA which contain the biological sources and sinks 
    … …  
    629602 
    630603   !!====================================================================== 
    631 END MODULE  p4zprod 
     604END MODULE p4zprod 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zrem.F90

    r5602 r7256  
    4444   REAL(wp), PUBLIC ::  xsiremlab  !: fast remineralisation rate of POC  
    4545   REAL(wp), PUBLIC ::  xsilab     !: fraction of labile biogenic silica  
    46    REAL(wp), PUBLIC ::  oxymin     !: halk saturation constant for anoxia  
    47  
    4846 
    4947   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   denitr     !: denitrification array 
    … …  
    111109                  zdepprod(ji,jj,jk) = zdepmin**0.273 
    112110               ENDIF 
    113             END DO 
    114          END DO 
    115       END DO 
    116  
    117       DO jk = 1, jpkm1 
    118          DO jj = 1, jpj 
    119             DO ji = 1, jpi 
    120                ! denitrification factor computed from O2 levels 
    121                nitrfac(ji,jj,jk) = MAX(  0.e0, 0.4 * ( 6.e-6  - trb(ji,jj,jk,jpoxy) )    & 
    122                   &                                / ( oxymin + trb(ji,jj,jk,jpoxy) )  ) 
    123                nitrfac(ji,jj,jk) = MIN( 1., nitrfac(ji,jj,jk) ) 
    124111            END DO 
    125112         END DO 
    … …  
    357344      !! 
    358345      !!---------------------------------------------------------------------- 
    359       NAMELIST/nampisrem/ xremik, xremip, nitrif, xsirem, xsiremlab, xsilab,   & 
    360       &                   oxymin 
     346      NAMELIST/nampisrem/ xremik, xremip, nitrif, xsirem, xsiremlab, xsilab 
    361347      INTEGER :: ios                 ! Local integer output status for namelist read 
    362348 
    … …  
    380366         WRITE(numout,*) '    fraction of labile biogenic silica        xsilab    =', xsilab 
    381367         WRITE(numout,*) '    NH4 nitrification rate                    nitrif    =', nitrif 
    382          WRITE(numout,*) '    halk saturation constant for anoxia       oxymin    =', oxymin 
    383368      ENDIF 
    384369      ! 
    385       nitrfac (:,:,:) = 0._wp 
    386370      denitr  (:,:,:) = 0._wp 
    387371      denitnh4(:,:,:) = 0._wp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r5602 r7256  
    159159      IF( ln_ndepo ) THEN 
    160160         IF( kt == nit000 .OR. ( kt /= nit000 .AND. ntimes_ndep > 1 ) ) THEN 
    161             CALL fld_read( kt, 1, sf_ndepo ) 
    162             DO jj = 1, jpj 
    163                DO ji = 1, jpi 
    164                   nitdep(ji,jj) = sf_ndepo(1)%fnow(ji,jj,1) / rno3 / ( 14E6 * ryyss * fse3t(ji,jj,1) + rtrn ) 
    165                END DO 
    166             END DO 
     161             zcoef = rno3 * 14E6 * ryyss 
     162             CALL fld_read( kt, 1, sf_ndepo ) 
     163             nitdep(:,:) = sf_ndepo(1)%fnow(:,:,1) / zcoef / fse3t(:,:,1)  
     164         ENDIF 
     165         IF( lk_vvl ) THEN 
     166           zcoef = rno3 * 14E6 * ryyss 
     167           nitdep(:,:) = sf_ndepo(1)%fnow(:,:,1) / zcoef / fse3t(:,:,1)  
    167168         ENDIF 
    168169      ENDIF 
    … …  
    266267      IF( lk_offline ) THEN 
    267268        nk_rnf(:,:) = 1 
    268         h_rnf (:,:) = fsdept(:,:,1) 
     269        h_rnf (:,:) = e3t_0(:,:,1) 
    269270      ENDIF 
    270271 
    … …  
    455456            DO jj = 1, jpj 
    456457               DO ji = 1, jpi 
    457                   zexpide   = MIN( 8.,( fsdept(ji,jj,jk) / 500. )**(-1.5) ) 
     458                  zexpide   = MIN( 8.,( gdept_0(ji,jj,jk) / 500. )**(-1.5) ) 
    458459                  zdenitide = -0.9543 + 0.7662 * LOG( zexpide ) - 0.235 * LOG( zexpide )**2 
    459460                  zcmask(ji,jj,jk) = zcmask(ji,jj,jk) * MIN( 1., EXP( zdenitide ) / 0.5 ) 
    … …  
    465466         ironsed(:,:,jpk) = 0._wp 
    466467         DO jk = 1, jpkm1 
    467             ironsed(:,:,jk) = sedfeinput * zcmask(:,:,jk) / ( fse3t(:,:,jk) * rday ) 
     468            ironsed(:,:,jk) = sedfeinput * zcmask(:,:,jk) / ( e3t_0(:,:,jk) * rday ) 
    468469         END DO 
    469470         DEALLOCATE( zcmask) 
    … …  
    483484         CALL iom_close( numhydro ) 
    484485         ! 
    485          hydrofe(:,:,:) = ( hydrofe(:,:,:) * hratio ) / ( cvol(:,:,:) * ryyss + rtrn ) / 1000._wp 
     486         DO jk = 1, jpk 
     487            hydrofe(:,:,jk) = ( hydrofe(:,:,jk) * hratio ) / ( e1e2t(:,:) * e3t_0(:,:,jk) * ryyss + rtrn ) / 1000._wp 
     488         ENDDO 
    486489         ! 
    487490      ENDIF 
    … …  
    519522 
    520523   !!====================================================================== 
    521 END MODULE  p4zsbc 
     524END MODULE p4zsbc 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r5602 r7256  
    7272      CHARACTER (len=25) :: charout 
    7373      REAL(wp), POINTER, DIMENSION(:,:  ) :: zpdep, zsidep, zwork1, zwork2, zwork3 
     74      REAL(wp), POINTER, DIMENSION(:,:)   :: zsedcal, zsedsi, zsedc 
    7475      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdenit2d, zironice, zbureff 
    7576      REAL(wp), POINTER, DIMENSION(:,:  ) :: zwsbio3, zwsbio4, zwscal 
    … …  
    8384      ! Allocate temporary workspace 
    8485      CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
     86      CALL wrk_alloc( jpi, jpj, zsedcal,  zsedsi, zsedc ) 
    8587      CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    8688      CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    9193      zwork2  (:,:) = 0.e0 
    9294      zwork3  (:,:) = 0.e0 
     95      zsedsi   (:,:) = 0.e0 
     96      zsedcal  (:,:) = 0.e0 
     97      zsedc    (:,:) = 0.e0 
    9398 
    9499      ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. 
    … …  
    298303            tra(ji,jj,ikt,jptal) =  tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 
    299304            tra(ji,jj,ikt,jpdic) =  tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 
     305            zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss / zdep 
     306            zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss / zdep 
    300307#endif 
    301308         END DO 
    … …  
    336343            tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 
    337344            tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 
    338             sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 
     345            sdenit(ji,jj) = rdenit * zpdenit / zdep 
     346            zsedc(ji,jj)   = (1. - zrivno3) * zwstpoc / zdep 
    339347#endif 
    340348         END DO 
    … …  
    392400               CALL iom_put( "INTNFIX" , zwork1 )  
    393401            ENDIF 
     402            IF( iom_use("SedCal" ) ) CALL iom_put( "SedCal", zsedcal(:,:) * 1.e+3 ) 
     403            IF( iom_use("SedSi" ) )  CALL iom_put( "SedSi",  zsedsi (:,:) * 1.e+3 ) 
     404            IF( iom_use("SedC" ) )   CALL iom_put( "SedC",   zsedc  (:,:) * 1.e+3 ) 
     405            IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", sdenit (:,:) * 1.e+3 * rno3 ) 
    394406         ENDIF 
    395407      ELSE 
    … …  
    405417      ! 
    406418      CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
     419      CALL wrk_dealloc( jpi, jpj, zsedcal , zsedsi, zsedc ) 
    407420      CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    408421      CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    436449 
    437450   !!====================================================================== 
    438 END MODULE  p4zsed 
     451END MODULE p4zsed 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsink.F90

    r5602 r7256  
    913913 
    914914   !!====================================================================== 
    915 END MODULE  p4zsink 
     915END MODULE p4zsink 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

    r5602 r7256  
    3838 
    3939   REAL(wp) :: alkbudget, no3budget, silbudget, ferbudget, po4budget 
    40    REAL(wp) :: xfact1, xfact2 
     40   REAL(wp) :: xfact1, xfact2, xfact3 
    4141   INTEGER ::  numco2, numnut, numnit  !: logical unit for co2 budget 
    4242 
    … …  
    133133         ! 
    134134         CALL p4z_bio( kt, jnt )   ! Biology 
    135          CALL p4z_sed( kt, jnt )   ! Sedimentation 
    136135         CALL p4z_lys( kt, jnt )   ! Compute CaCO3 saturation 
     136         CALL p4z_sed( kt, jnt )   ! Surface and Bottom boundary conditions 
    137137         CALL p4z_flx( kt, jnt )   ! Compute surface fluxes 
    138138         ! 
    … …  
    474474      !!--------------------------------------------------------------------- 
    475475      ! 
    476       INTEGER , INTENT( in ) ::   kt      ! ocean time-step index       
    477       REAL(wp)               ::  zfact        
    478       REAL(wp) ::  zrdenittot, zsdenittot, znitrpottot 
     476      INTEGER, INTENT( in ) ::   kt      ! ocean time-step index       
     477      REAL(wp)             ::  zrdenittot, zsdenittot, znitrpottot 
    479478      CHARACTER(LEN=100)   ::   cltxt 
    480479      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvol 
    … …  
    492491            xfact1 = rfact2r * 12. / 1.e15 * ryyss    ! conversion molC/kt --> PgC/yr 
    493492            xfact2 = 1.e+3 * rno3 * 14. / 1.e12 * ryyss   ! conversion molC/l/s ----> TgN/m3/yr 
     493            xfact3 = 1.e+3 * rfact2r * rno3   ! conversion molC/l/kt ----> molN/m3/s 
    494494            cltxt='time-step   Alkalinity        Nitrate        Phosphorus         Silicate           Iron' 
    495495            IF( lwp ) WRITE(numnut,*)  TRIM(cltxt) 
    … …  
    574574      IF( iom_use( "Sdenit" ) .OR.  ( ln_check_mass .AND. kt == nitend )  ) THEN 
    575575         zsdenittot   = glob_sum ( sdenit(:,:) * e1e2t(:,:) ) 
    576          CALL iom_put( "Sdenit", sdenit(:,:) * zfact * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
     576         CALL iom_put( "Sdenit", sdenit(:,:) * xfact3 * tmask(:,:,1) )  ! Nitrate reduction in the sediments 
    577577      ENDIF 
    578578 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r5602 r7256  
    101101   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hi         !: ??? 
    102102   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   excess     !: ??? 
     103   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aphscale   !:  
     104 
    103105 
    104106   !!* Temperature dependancy of SMS terms 
    … …  
    154156         &      ak23(jpi,jpj,jpk)    , aksp  (jpi,jpj,jpk) ,       & 
    155157         &      akw3(jpi,jpj,jpk)    , borat (jpi,jpj,jpk) ,       & 
    156          &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,     STAT=ierr(4) ) 
     158         &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,       & 
     159         &      aphscale(jpi,jpj,jpk),                           STAT=ierr(4) ) 
    157160         ! 
    158161      !* Temperature dependancy of SMS terms 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/trcice_pisces.F90

    r5602 r7256  
    2929CONTAINS 
    3030 
     31 
    3132   SUBROUTINE trc_ice_ini_pisces 
    3233      !!---------------------------------------------------------------------- 
    33       !!                   ***  ROUTINE trc_ice_ini_pisces *** 
     34      !!                   ***  ROUTINE trc_ini_pisces *** 
     35      !! 
     36      !! ** Purpose :   Initialisation of the PISCES biochemical model 
     37      !!---------------------------------------------------------------------- 
     38 
     39      IF( lk_p4z ) THEN  ;   CALL p4z_ice_ini   !  PISCES 
     40      ELSE               ;   CALL p2z_ice_ini   !  LOBSTER 
     41      ENDIF 
     42 
     43   END SUBROUTINE trc_ice_ini_pisces 
     44 
     45 
     46   SUBROUTINE p4z_ice_ini 
     47 
     48#if defined key_pisces  
     49      !!---------------------------------------------------------------------- 
     50      !!                   ***  ROUTINE p4z_ice_ini *** 
    3451      !! 
    3552      !! ** Purpose :   PISCES fake sea ice model setting 
    … …  
    5875 
    5976                                        !--- Dummy variables 
    60       REAL(wp), DIMENSION(jptra,2) & 
    61                ::  zratio            ! effective ice-ocean tracer cc ratio 
     77      REAL(wp), DIMENSION(jp_pisces,2)  :: zratio  ! effective ice-ocean tracer cc ratio 
     78      REAL(wp), DIMENSION(jp_pisces,4)  :: zpisc   ! prescribes concentration  
     79      !                                            !  1:global, 2:Arctic, 3:Antarctic, 4:Baltic 
     80 
    6281      REAL(wp), DIMENSION(2) :: zrs  ! ice-ocean salinity ratio, 1 - global, 2- Baltic 
    6382      REAL(wp) :: zsice_bal          ! prescribed ice salinity in the Baltic 
    … …  
    8099      ! fluxes 
    81100 
    82       !--- Global case  
    83       IF ( cn_trc_o(jpdic) == 'GL ' ) trc_o(:,:,jpdic) =  1.99e-3_wp  
    84       IF ( cn_trc_o(jpdoc) == 'GL ' ) trc_o(:,:,jpdoc) =  2.04e-5_wp  
    85       IF ( cn_trc_o(jptal) == 'GL ' ) trc_o(:,:,jptal) =  2.31e-3_wp  
    86       IF ( cn_trc_o(jpoxy) == 'GL ' ) trc_o(:,:,jpoxy) =  2.47e-4_wp 
    87       IF ( cn_trc_o(jpcal) == 'GL ' ) trc_o(:,:,jpcal) =  1.04e-8_wp 
    88       IF ( cn_trc_o(jppo4) == 'GL ' ) trc_o(:,:,jppo4) =  5.77e-7_wp / po4r  
    89       IF ( cn_trc_o(jppoc) == 'GL ' ) trc_o(:,:,jppoc) =  1.27e-6_wp   
     101      !--- Global values 
     102      zpisc(jpdic,1) =  1.99e-3_wp  
     103      zpisc(jpdoc,1) =  2.04e-5_wp  
     104      zpisc(jptal,1) =  2.31e-3_wp  
     105      zpisc(jpoxy,1) =  2.47e-4_wp 
     106      zpisc(jpcal,1) =  1.04e-8_wp 
     107      zpisc(jppo4,1) =  5.77e-7_wp / po4r  
     108      zpisc(jppoc,1) =  1.27e-6_wp   
    90109#  if ! defined key_kriest 
    91       IF ( cn_trc_o(jpgoc) == 'GL ' ) trc_o(:,:,jpgoc) =  5.23e-8_wp   
    92       IF ( cn_trc_o(jpbfe) == 'GL ' ) trc_o(:,:,jpbfe) =  9.84e-13_wp  
     110      zpisc(jpgoc,1) =  5.23e-8_wp   
     111      zpisc(jpbfe,1) =  9.84e-13_wp  
    93112#  else 
    94       IF ( cn_trc_o(jpnum) == 'GL ' ) trc_o(:,:,jpnum) = 0. ! could not get this value since did not use it 
     113      zpisc(jpnum,1) = 0. ! could not get this value since did not use it 
    95114#  endif 
    96       IF ( cn_trc_o(jpsil) == 'GL ' ) trc_o(:,:,jpsil) =  7.36e-6_wp   
    97       IF ( cn_trc_o(jpdsi) == 'GL ' ) trc_o(:,:,jpdsi) =  1.07e-7_wp  
    98       IF ( cn_trc_o(jpgsi) == 'GL ' ) trc_o(:,:,jpgsi) =  1.53e-8_wp 
    99       IF ( cn_trc_o(jpphy) == 'GL ' ) trc_o(:,:,jpphy) =  9.57e-8_wp 
    100       IF ( cn_trc_o(jpdia) == 'GL ' ) trc_o(:,:,jpdia) =  4.24e-7_wp 
    101       IF ( cn_trc_o(jpzoo) == 'GL ' ) trc_o(:,:,jpzoo) =  6.07e-7_wp 
    102       IF ( cn_trc_o(jpmes) == 'GL ' ) trc_o(:,:,jpmes) =  3.44e-7_wp 
    103       IF ( cn_trc_o(jpfer) == 'GL ' ) trc_o(:,:,jpfer) =  4.06e-10_wp 
    104       IF ( cn_trc_o(jpsfe) == 'GL ' ) trc_o(:,:,jpsfe) =  2.51e-11_wp 
    105       IF ( cn_trc_o(jpdfe) == 'GL ' ) trc_o(:,:,jpdfe) =  6.57e-12_wp 
    106       IF ( cn_trc_o(jpnfe) == 'GL ' ) trc_o(:,:,jpnfe) =  1.76e-11_wp 
    107       IF ( cn_trc_o(jpnch) == 'GL ' ) trc_o(:,:,jpnch) =  1.67e-7_wp 
    108       IF ( cn_trc_o(jpdch) == 'GL ' ) trc_o(:,:,jpdch) =  1.02e-7_wp 
    109       IF ( cn_trc_o(jpno3) == 'GL ' ) trc_o(:,:,jpno3) =  5.79e-6_wp / rno3  
    110       IF ( cn_trc_o(jpnh4) == 'GL ' ) trc_o(:,:,jpnh4) =  3.22e-7_wp / rno3 
     115      zpisc(jpsil,1) =  7.36e-6_wp   
     116      zpisc(jpdsi,1) =  1.07e-7_wp  
     117      zpisc(jpgsi,1) =  1.53e-8_wp 
     118      zpisc(jpphy,1) =  9.57e-8_wp 
     119      zpisc(jpdia,1) =  4.24e-7_wp 
     120      zpisc(jpzoo,1) =  6.07e-7_wp 
     121      zpisc(jpmes,1) =  3.44e-7_wp 
     122      zpisc(jpfer,1) =  4.06e-10_wp 
     123      zpisc(jpsfe,1) =  2.51e-11_wp 
     124      zpisc(jpdfe,1) =  6.57e-12_wp 
     125      zpisc(jpnfe,1) =  1.76e-11_wp 
     126      zpisc(jpnch,1) =  1.67e-7_wp 
     127      zpisc(jpdch,1) =  1.02e-7_wp 
     128      zpisc(jpno3,1) =  5.79e-6_wp / rno3  
     129      zpisc(jpnh4,1) =  3.22e-7_wp / rno3 
    111130 
    112131      !--- Arctic specificities (dissolved inorganic & DOM) 
    113       IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdic) =  1.98e-3_wp  ; END WHERE ; ENDIF 
    114       IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdoc) =  6.00e-6_wp  ; END WHERE ; ENDIF 
    115       IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jptal) =  2.13e-3_wp  ; END WHERE ; ENDIF 
    116       IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpoxy) =  3.65e-4_wp  ; END WHERE ; ENDIF 
    117       IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpcal) =  1.50e-9_wp  ; END WHERE ; ENDIF 
    118       IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppo4) =  4.09e-7_wp / po4r ; END WHERE ; ENDIF 
    119       IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jppoc) =  4.05e-7_wp  ; END WHERE ; ENDIF 
     132      zpisc(jpdic,2) =  1.98e-3_wp  
     133      zpisc(jpdoc,2) =  6.00e-6_wp  
     134      zpisc(jptal,2) =  2.13e-3_wp  
     135      zpisc(jpoxy,2) =  3.65e-4_wp   
     136      zpisc(jpcal,2) =  1.50e-9_wp   
     137      zpisc(jppo4,2) =  4.09e-7_wp / po4r  
     138      zpisc(jppoc,2) =  4.05e-7_wp   
    120139#  if ! defined key_kriest 
    121       IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgoc) =  2.84e-8_wp  ; END WHERE ; ENDIF 
    122       IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpbfe) =  7.03e-13_wp ; END WHERE ; ENDIF 
     140      zpisc(jpgoc,2) =  2.84e-8_wp   
     141      zpisc(jpbfe,2) =  7.03e-13_wp  
    123142#  else 
    124       IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnum) =  0.00e-00_wp ; END WHERE ; ENDIF 
     143      zpisc(jpnum,2) =  0.00e-00_wp  
    125144#  endif 
    126       IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsil) =  6.87e-6_wp  ; END WHERE ; ENDIF 
    127       IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdsi) =  1.73e-7_wp  ; END WHERE ; ENDIF 
    128       IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpgsi) =  7.93e-9_wp  ; END WHERE ; ENDIF 
    129       IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpphy) =  5.25e-7_wp  ; END WHERE ; ENDIF 
    130       IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdia) =  7.75e-7_wp  ; END WHERE ; ENDIF 
    131       IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpzoo) =  3.34e-7_wp  ; END WHERE ; ENDIF 
    132       IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpmes) =  2.49e-7_wp  ; END WHERE ; ENDIF 
    133       IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpfer) =  1.43e-9_wp  ; END WHERE ; ENDIF 
    134       IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpsfe) =  2.21e-11_wp ; END WHERE ; ENDIF 
    135       IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdfe) =  2.04e-11_wp ; END WHERE ; ENDIF 
    136       IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnfe) =  1.75e-11_wp ; END WHERE ; ENDIF 
    137       IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnch) =  1.46e-07_wp ; END WHERE ; ENDIF 
    138       IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpdch) =  2.36e-07_wp ; END WHERE ; ENDIF 
    139       IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpno3) =  3.51e-06_wp / rno3 ; END WHERE ; ENDIF 
    140       IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) >= 00._wp ) ; trc_o(:,:,jpnh4) =  6.15e-08_wp / rno3 ; END WHERE ; ENDIF 
     145      zpisc(jpsil,2) =  6.87e-6_wp   
     146      zpisc(jpdsi,2) =  1.73e-7_wp  
     147      zpisc(jpgsi,2) =  7.93e-9_wp 
     148      zpisc(jpphy,2) =  5.25e-7_wp   
     149      zpisc(jpdia,2) =  7.75e-7_wp  
     150      zpisc(jpzoo,2) =  3.34e-7_wp 
     151      zpisc(jpmes,2) =  2.49e-7_wp   
     152      zpisc(jpfer,2) =  1.43e-9_wp  
     153      zpisc(jpsfe,2) =  2.21e-11_wp  
     154      zpisc(jpdfe,2) =  2.04e-11_wp  
     155      zpisc(jpnfe,2) =  1.75e-11_wp  
     156      zpisc(jpnch,2) =  1.46e-07_wp  
     157      zpisc(jpdch,2) =  2.36e-07_wp  
     158      zpisc(jpno3,2) =  3.51e-06_wp / rno3  
     159      zpisc(jpnh4,2) =  6.15e-08_wp / rno3  
    141160 
    142161      !--- Antarctic specificities (dissolved inorganic & DOM) 
    143       IF ( cn_trc_o(jpdic) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdic) =  2.20e-3_wp  ; END WHERE ; ENDIF 
    144       IF ( cn_trc_o(jpdoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdoc) =  7.02e-6_wp  ; END WHERE ; ENDIF 
    145       IF ( cn_trc_o(jptal) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jptal) =  2.37e-3_wp  ; END WHERE ; ENDIF 
    146       IF ( cn_trc_o(jpoxy) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpoxy) =  3.42e-4_wp  ; END WHERE ; ENDIF 
    147       IF ( cn_trc_o(jpcal) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpcal) =  3.17e-9_wp  ; END WHERE ; ENDIF 
    148       IF ( cn_trc_o(jppo4) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jppo4) =  1.88e-6_wp / po4r  ; END WHERE ; ENDIF 
    149       IF ( cn_trc_o(jppoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jppoc) =  1.13e-6_wp  ; END WHERE ; ENDIF 
     162      zpisc(jpdic,3) =  2.20e-3_wp   
     163      zpisc(jpdoc,3) =  7.02e-6_wp   
     164      zpisc(jptal,3) =  2.37e-3_wp   
     165      zpisc(jpoxy,3) =  3.42e-4_wp   
     166      zpisc(jpcal,3) =  3.17e-9_wp   
     167      zpisc(jppo4,3) =  1.88e-6_wp / po4r   
     168      zpisc(jppoc,3) =  1.13e-6_wp   
    150169#  if ! defined key_kriest 
    151       IF ( cn_trc_o(jpgoc) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpgoc) =  2.89e-8_wp  ; END WHERE ; ENDIF 
    152       IF ( cn_trc_o(jpbfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpbfe) =  5.63e-13_wp ; END WHERE ; ENDIF 
     170      zpisc(jpgoc,3) =  2.89e-8_wp   
     171      zpisc(jpbfe,3) =  5.63e-13_wp  
    153172#  else 
    154       IF ( cn_trc_o(jpnum) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnum) =  0.00e-00_wp ; END WHERE ; ENDIF 
     173      zpisc(jpnum,3) =  0.00e-00_wp  
    155174#  endif 
    156       IF ( cn_trc_o(jpsil) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpsil) =  4.96e-5_wp  ; END WHERE ; ENDIF 
    157       IF ( cn_trc_o(jpdsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdsi) =  5.63e-7_wp  ; END WHERE ; ENDIF 
    158       IF ( cn_trc_o(jpgsi) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpgsi) =  5.35e-8_wp  ; END WHERE ; ENDIF 
    159       IF ( cn_trc_o(jpphy) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpphy) =  8.10e-7_wp  ; END WHERE ; ENDIF 
    160       IF ( cn_trc_o(jpdia) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdia) =  5.77e-7_wp  ; END WHERE ; ENDIF 
    161       IF ( cn_trc_o(jpzoo) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpzoo) =  6.68e-7_wp  ; END WHERE ; ENDIF 
    162       IF ( cn_trc_o(jpmes) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpmes) =  3.55e-7_wp  ; END WHERE ; ENDIF 
    163       IF ( cn_trc_o(jpfer) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpfer) =  1.62e-10_wp ; END WHERE ; ENDIF 
    164       IF ( cn_trc_o(jpsfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpsfe) =  2.29e-11_wp ; END WHERE ; ENDIF 
    165       IF ( cn_trc_o(jpdfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdfe) =  8.75e-12_wp ; END WHERE ; ENDIF 
    166       IF ( cn_trc_o(jpnfe) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnfe) =  1.48e-11_wp ; END WHERE ; ENDIF 
    167       IF ( cn_trc_o(jpnch) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnch) =  2.02e-7_wp  ; END WHERE ; ENDIF 
    168       IF ( cn_trc_o(jpdch) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpdch) =  1.60e-7_wp  ; END WHERE ; ENDIF 
    169       IF ( cn_trc_o(jpno3) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpno3) =  2.64e-5_wp / rno3  ; END WHERE ; ENDIF 
    170       IF ( cn_trc_o(jpnh4) == 'AA ' ) THEN ; WHERE( gphit(:,:) <  00._wp ) ; trc_o(:,:,jpnh4) =  3.39e-7_wp / rno3  ; END WHERE ; ENDIF 
     175      zpisc(jpsil,3) =  4.96e-5_wp   
     176      zpisc(jpdsi,3) =  5.63e-7_wp  
     177      zpisc(jpgsi,3) =  5.35e-8_wp 
     178      zpisc(jpphy,3) =  8.10e-7_wp   
     179      zpisc(jpdia,3) =  5.77e-7_wp  
     180      zpisc(jpzoo,3) =  6.68e-7_wp 
     181      zpisc(jpmes,3) =  3.55e-7_wp   
     182      zpisc(jpfer,3) =  1.62e-10_wp 
     183      zpisc(jpsfe,3) =  2.29e-11_wp  
     184      zpisc(jpdfe,3) =  8.75e-12_wp 
     185      zpisc(jpnfe,3) =  1.48e-11_wp  
     186      zpisc(jpnch,3) =  2.02e-7_wp   
     187      zpisc(jpdch,3) =  1.60e-7_wp   
     188      zpisc(jpno3,3) =  2.64e-5_wp / rno3   
     189      zpisc(jpnh4,3) =  3.39e-7_wp / rno3   
    171190 
    172191      !--- Baltic Sea particular case for ORCA configurations 
    173       IF( cp_cfg == "orca" ) THEN            ! Baltic mask 
    174          WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    175                 54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    176          trc_o(:,:,jpdic) = 1.14e-3_wp 
    177          trc_o(:,:,jpdoc) = 1.06e-5_wp 
    178          trc_o(:,:,jptal) = 1.16e-3_wp 
    179          trc_o(:,:,jpoxy) = 3.71e-4_wp 
    180          trc_o(:,:,jpcal) = 1.51e-9_wp 
    181          trc_o(:,:,jppo4) = 2.85e-9_wp / po4r 
    182          trc_o(:,:,jppoc) = 4.84e-7_wp 
     192      zpisc(jpdic,4) = 1.14e-3_wp 
     193      zpisc(jpdoc,4) = 1.06e-5_wp 
     194      zpisc(jptal,4) = 1.16e-3_wp 
     195      zpisc(jpoxy,4) = 3.71e-4_wp 
     196      zpisc(jpcal,4) = 1.51e-9_wp 
     197      zpisc(jppo4,4) = 2.85e-9_wp / po4r 
     198      zpisc(jppoc,4) = 4.84e-7_wp 
    183199#  if ! defined key_kriest 
    184          trc_o(:,:,jpgoc) = 1.05e-8_wp 
    185          trc_o(:,:,jpbfe) = 4.97e-13_wp 
     200      zpisc(jpgoc,4) = 1.05e-8_wp 
     201      zpisc(jpbfe,4) = 4.97e-13_wp 
    186202#  else 
    187          trc_o(:,:,jpnum) = 0. ! could not get this value 
     203      zpisc(jpnum,4) = 0. ! could not get this value 
    188204#  endif 
    189          trc_o(:,:,jpsil) = 4.91e-5_wp 
    190          trc_o(:,:,jpdsi) = 3.25e-7_wp 
    191          trc_o(:,:,jpgsi) = 1.93e-8_wp 
    192          trc_o(:,:,jpphy) = 6.64e-7_wp 
    193          trc_o(:,:,jpdia) = 3.41e-7_wp 
    194          trc_o(:,:,jpzoo) = 3.83e-7_wp 
    195          trc_o(:,:,jpmes) = 0.225e-6_wp 
    196          trc_o(:,:,jpfer) = 2.45e-9_wp 
    197          trc_o(:,:,jpsfe) = 3.89e-11_wp 
    198          trc_o(:,:,jpdfe) = 1.33e-11_wp 
    199          trc_o(:,:,jpnfe) = 2.62e-11_wp 
    200          trc_o(:,:,jpnch) = 1.17e-7_wp 
    201          trc_o(:,:,jpdch) = 9.69e-8_wp 
    202          trc_o(:,:,jpno3) = 5.36e-5_wp / rno3 
    203          trc_o(:,:,jpnh4) = 7.18e-7_wp / rno3 
    204          END WHERE 
    205       ENDIF ! cfg 
     205      zpisc(jpsil,4) = 4.91e-5_wp 
     206      zpisc(jpdsi,4) = 3.25e-7_wp 
     207      zpisc(jpgsi,4) = 1.93e-8_wp 
     208      zpisc(jpphy,4) = 6.64e-7_wp 
     209      zpisc(jpdia,4) = 3.41e-7_wp 
     210      zpisc(jpzoo,4) = 3.83e-7_wp 
     211      zpisc(jpmes,4) = 0.225e-6_wp 
     212      zpisc(jpfer,4) = 2.45e-9_wp 
     213      zpisc(jpsfe,4) = 3.89e-11_wp 
     214      zpisc(jpdfe,4) = 1.33e-11_wp 
     215      zpisc(jpnfe,4) = 2.62e-11_wp 
     216      zpisc(jpnch,4) = 1.17e-7_wp 
     217      zpisc(jpdch,4) = 9.69e-8_wp 
     218      zpisc(jpno3,4) = 5.36e-5_wp / rno3 
     219      zpisc(jpnh4,4) = 7.18e-7_wp / rno3 
     220  
     221      DO jn = jp_pcs0, jp_pcs1 
     222         IF( cn_trc_o(jn) == 'GL ' ) trc_o(:,:,jn) = zpisc(jn,1)  ! Global case 
     223         IF( cn_trc_o(jn) == 'AA ' ) THEN  
     224            WHERE( gphit(:,:) >= 0._wp ) ; trc_o(:,:,jn) = zpisc(jn,2) ; END WHERE ! Arctic  
     225            WHERE( gphit(:,:) <  0._wp ) ; trc_o(:,:,jn) = zpisc(jn,3) ; END WHERE ! Antarctic  
     226         ENDIF 
     227         IF( cp_cfg == "orca" ) THEN     !  Baltic Sea particular case for ORCA configurations 
     228             WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
     229                    54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
     230                    trc_o(:,:,jn) = zpisc(jn,4) 
     231            END WHERE 
     232         ENDIF  
     233      ENDDO 
     234 
     235 
    206236 
    207237      !----------------------------- 
    … …  
    217247 
    218248      DO jn = jp_pcs0, jp_pcs1 
    219          IF ( trc_ice_ratio(jn) >= 0._wp )  zratio(jn,:) = trc_ice_ratio(jn) 
    220          IF ( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) 
    221          IF ( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp 
     249         IF( trc_ice_ratio(jn) >= 0._wp )  zratio(jn,:) = trc_ice_ratio(jn) 
     250         IF( trc_ice_ratio(jn) == -1._wp ) zratio(jn,:) = zrs(:) 
     251         IF( trc_ice_ratio(jn) == -2._wp ) zratio(jn,:) = -9999.99_wp 
    222252      END DO 
    223253 
    … …  
    227257      DO jn = jp_pcs0, jp_pcs1 
    228258         !-- Everywhere but in the Baltic 
    229          IF ( trc_ice_ratio(jn) >= -1._wp ) THEN !! no prescribed concentration 
    230                                               !! (typically everything but iron)  
     259         IF ( trc_ice_ratio(jn) >= -1._wp ) THEN ! no prescribed conc. ; typically everything but iron)  
    231260            trc_i(:,:,jn) = zratio(jn,1) * trc_o(:,:,jn)  
    232          ELSE                                 !! prescribed concentration 
     261         ELSE                                    ! prescribed concentration 
    233262            trc_i(:,:,jn) = trc_ice_prescr(jn) 
    234263         ENDIF 
    235264        
    236265         !-- Baltic 
    237          IF( cp_cfg == "orca" ) THEN !! Baltic treated seperately for ORCA configs 
    238             IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN !! no prescribed concentration 
    239                                                  !! (typically everything but iron)  
     266         IF( cp_cfg == "orca" ) THEN  ! Baltic treated seperately for ORCA configs 
     267            IF ( trc_ice_ratio(jn) >= - 1._wp ) THEN ! no prescribed conc. ; typically everything but iron)  
    240268               WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    241269                      54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    242270                     trc_i(:,:,jn) = zratio(jn,2) * trc_o(:,:,jn)  
    243271               END WHERE 
    244             ELSE                                 !! prescribed tracer concentration in ice 
     272            ELSE                                 ! prescribed tracer concentration in ice 
    245273               WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.    & 
    246274                   54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp ) 
    … …  
    251279      ! 
    252280      END DO ! jn 
    253  
    254    END SUBROUTINE trc_ice_ini_pisces 
     281#endif 
     282 
     283   END SUBROUTINE p4z_ice_ini 
     284 
     285   SUBROUTINE p2z_ice_ini 
     286#if defined key_pisces_reduced  
     287      !!---------------------------------------------------------------------- 
     288      !!                   ***  ROUTINE p2z_ice_ini *** 
     289      !! 
     290      !! ** Purpose :   Initialisation of the LOBSTER biochemical model 
     291      !!---------------------------------------------------------------------- 
     292#endif 
     293   END SUBROUTINE p2z_ice_ini 
     294 
    255295 
    256296#else 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90

    r5602 r7256  
    115115      po4r    =   1._wp / 122._wp 
    116116      o2nit   =  32._wp / 122._wp 
    117       rdenit  = 105._wp /  16._wp 
     117      o2ut    = 133._wp / 122._wp 
     118      rdenit  =  ( ( o2ut + o2nit ) * 0.80 - rno3 - rno3 * 0.60 ) / rno3 
    118119      rdenita =   3._wp /  5._wp 
    119       o2ut    = 133._wp / 122._wp 
     120 
    120121 
    121122      ! Initialization of tracer concentration in case of  no restart  

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90

    r6101 r7256  
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   restotr   ! restoring coeff. on tracers (s-1) 
    3636 
    37    INTEGER, PARAMETER           ::   npncts   = 5        ! number of closed sea 
     37   INTEGER, PARAMETER           ::   npncts   = 8        ! number of closed sea 
    3838   INTEGER, DIMENSION(npncts)   ::   nctsi1, nctsj1      ! south-west closed sea limits (i,j) 
    3939   INTEGER, DIMENSION(npncts)   ::   nctsi2, nctsj2      ! north-east closed sea limits (i,j) 
    … …  
    107107                
    108108               jl = n_trc_index(jn)  
    109                CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    110                ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
     109               CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    111110 
    112111               SELECT CASE ( nn_zdmp_tr ) 
    … …  
    208207            ! 
    209208                                                        ! Caspian Sea 
    210             nctsi1(1)   = 332  ; nctsj1(1)   = 243 - isrow 
    211             nctsi2(1)   = 344  ; nctsj2(1)   = 275 - isrow 
     209            nctsi1(1)   = 333  ; nctsj1(1)   = 243 - isrow 
     210            nctsi2(1)   = 342  ; nctsj2(1)   = 274 - isrow 
     211            !                                           ! Lake Superior 
     212            nctsi1(2)   = 198  ; nctsj1(2)   = 258 - isrow 
     213            nctsi2(2)   = 204  ; nctsj2(2)   = 262 - isrow 
     214            !                                           ! Lake Michigan 
     215            nctsi1(3)   = 201  ; nctsj1(3)   = 250 - isrow 
     216            nctsi2(3)   = 203  ; nctsj2(3)   = 256 - isrow 
     217            !                                           ! Lake Huron 
     218            nctsi1(4)   = 204  ; nctsj1(4)   = 252 - isrow 
     219            nctsi2(4)   = 209  ; nctsj2(4)   = 256 - isrow 
     220            !                                           ! Lake Erie 
     221            nctsi1(5)   = 206  ; nctsj1(5)   = 249 - isrow 
     222            nctsi2(5)   = 209  ; nctsj2(5)   = 251 - isrow 
     223            !                                           ! Lake Ontario 
     224            nctsi1(6)   = 210  ; nctsj1(6)   = 252 - isrow 
     225            nctsi2(6)   = 212  ; nctsj2(6)   = 252 - isrow 
     226            !                                           ! Victoria Lake 
     227            nctsi1(7)   = 321  ; nctsj1(7)   = 180 - isrow 
     228            nctsi2(7)   = 322  ; nctsj2(7)   = 189 - isrow 
     229            !                                           ! Baltic Sea 
     230            nctsi1(8)   = 297  ; nctsj1(8)   = 270 - isrow 
     231            nctsi2(8)   = 308  ; nctsj2(8)   = 293 - isrow 
    212232            !                                         
    213233            !                                           ! ======================= 
    … …  
    283303            IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    284304                jl = n_trc_index(jn) 
    285                 CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    286                 ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
     305                CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    287306                DO jc = 1, npncts 
    288307                   DO jk = 1, jpkm1 
    289308                      DO jj = nctsj1(jc), nctsj2(jc) 
    290309                         DO ji = nctsi1(jc), nctsi2(jc) 
    291                             trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) * tmask(ji,jj,jk) 
     310                            trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 
    292311                            trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    293312                         ENDDO 
    … …  
    317336      IF( nn_timing == 1 )  CALL timing_start('trc_dmp_init') 
    318337      ! 
     338      !Allocate arrays 
     339      IF( trc_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trc_dmp_init: unable to allocate arrays' ) 
    319340 
    320341      IF( lzoom )   nn_zdmp_tr = 0           ! restoring to climatology at closed north or south boundaries 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90

    r5602 r7256  
    1818   USE trc             ! ocean passive tracers variables 
    1919   USE trcnam_trp      ! passive tracers transport namelist variables 
    20    USE ldftra_oce      ! lateral diffusion coefficient on tracers 
     20   USE ldftra_oce,ONLY: ln_traldf_grif,rn_aht_0,rn_ahtb_0,lk_traldf_eiv     ! lateral diffusion coefficient on tracers 
    2121   USE ldfslp          ! ??? 
    2222   USE traldf_bilapg   ! lateral mixing            (tra_ldf_bilapg routine) 
    … …  
    5656      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    5757      !! 
    58       INTEGER            :: jn 
     58      INTEGER            :: ji, jj, jk, jn 
     59      REAL(wp)           :: zdep 
    5960      CHARACTER (len=22) :: charout 
    6061      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   ztrtrd 
    … …  
    6667 
    6768      rldf = rldf_rat 
    68  
     69      ! 
     70      r_fact_lap(:,:,:) = 1. 
     71      DO jk= 1, jpk 
     72         DO jj = 1, jpj 
     73            DO ji = 1, jpi 
     74               IF( fsdept(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 
     75                  zdep = MAX( fsdept(ji,jj,jk) - 1000., 0. ) / 1000. 
     76                  r_fact_lap(ji,jj,jk) = MAX( 1., rn_fact_lap * EXP( -zdep ) ) 
     77               ENDIF 
     78            END DO 
     79         END DO 
     80      END DO 
     81      ! 
    6982      IF( l_trdtrc )  THEN 
    7083         CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r5602 r7256  
    4040   REAL(wp), PUBLIC ::   rn_ahtrc_0          !: diffusivity coefficient for passive tracer (m2/s) 
    4141   REAL(wp), PUBLIC ::   rn_ahtrb_0          !: background diffusivity coefficient for passive tracer (m2/s) 
     42   REAL(wp), PUBLIC ::   rn_fact_lap         !: Enhanced zonal diffusivity coefficent in the equatorial domain 
    4243 
    4344   !                                        !!: ** Treatment of Negative concentrations ( nam_trcrad ) 
    … …  
    7475      NAMELIST/namtrc_ldf/ ln_trcldf_lap  ,     & 
    7576         &                 ln_trcldf_bilap, ln_trcldf_level,     & 
    76          &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0 
     77         &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0,   & 
     78         &                 rn_fact_lap 
     79 
    7780      NAMELIST/namtrc_zdf/ ln_trczdf_exp  , nn_trczdf_exp 
    7881      NAMELIST/namtrc_rad/ ln_trcrad 
    … …  
    127130         WRITE(numout,*) '      diffusivity coefficient                                 rn_ahtrc_0 = ', rn_ahtrc_0 
    128131         WRITE(numout,*) '      background hor. diffusivity                             rn_ahtrb_0 = ', rn_ahtrb_0 
     132         WRITE(numout,*) '      enhanced zonal diffusivity                             rn_fact_lap = ', rn_fact_lap 
    129133      ENDIF 
    130134 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r7210 r7256  
    104104      ENDIF 
    105105 
     106#if defined key_agrif 
     107      CALL Agrif_trc                   ! AGRIF zoom boundaries 
     108#endif 
    106109      ! Update after tracer on domain lateral boundaries 
    107110      DO jn = 1, jptra 
    … …  
    112115#if defined key_bdy 
    113116!!      CALL bdy_trc( kt )               ! BDY open boundaries 
    114 #endif 
    115 #if defined key_agrif 
    116       CALL Agrif_trc                   ! AGRIF zoom boundaries 
    117117#endif 
    118118 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r7210 r7256  
    103103         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    104104 
    105          IF( ln_rsttr .AND.    &                     ! Restart: read in restart  file 
     105         IF( ln_rsttr .AND. .NOT.ln_top_euler .AND.   &                     ! Restart: read in restart  file 
    106106            iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN 
    107107            IF(lwp) WRITE(numout,*) '          nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file' 
    … …  
    172172            END DO 
    173173         ENDIF 
     174         ! 
     175         CALL lbc_lnk( sbc_trc(:,:,jn), 'T', 1. ) 
    174176         !                                       Concentration dilution effect on tracers due to evaporation & precipitation  
    175177         DO jj = 2, jpj 
    … …  
    190192      !                                           Write in the tracer restar  file 
    191193      !                                          ******************************* 
    192       IF( lrst_trc ) THEN 
     194      IF( lrst_trc .AND. .NOT.ln_top_euler ) THEN 
    193195         IF(lwp) WRITE(numout,*) 
    194196         IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in tracer restart file ',   & 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r7217 r7256  
    1818   USE trcnam_trp      ! passive tracers transport namelist variables 
    1919   USE trabbl          ! bottom boundary layer               (trc_bbl routine) 
    20    USE trabbl_crs      ! bottom boundary layer               (trc_bbl routine) 
    2120   USE trcbbl          ! bottom boundary layer               (trc_bbl routine) 
    22    USE trcbbl_crs      ! bottom boundary layer               (trc_bbl routine) 
    2321   USE zdfkpp          ! KPP non-local tracer fluxes         (trc_kpp routine) 
    2422   USE trcdmp          ! internal damping                    (trc_dmp routine) 
    … …  
    7674      IF( .NOT. lk_c1d ) THEN 
    7775         ! 
    78                                CALL trc_sbc( kstp ) 
    79          IF( ln_crs_top ) THEN ;    CALL trc_bbl_crs( kstp ) 
    80          ELSE              ;    CALL trc_bbl( kstp ) 
    81          ENDIF 
    82          IF( ln_trcdmp )        CALL trc_dmp( kstp )            ! internal damping trends 
    83  
    84          IF( ln_crs_top ) THEN ;    CALL trc_adv_crs( kstp ) 
    85          ELSE              ;    CALL trc_adv( kstp ) 
     76                                       CALL trc_sbc( kstp ) 
     77         IF( lk_trabbl )               CALL trc_bbl( kstp ) 
     78         IF( ln_trcdmp )               CALL trc_dmp( kstp )            ! internal damping trends 
     79         IF( ln_crs_top ) THEN    ;    CALL trc_adv_crs( kstp ) 
     80         ELSE                     ;    CALL trc_adv( kstp ) 
    8681         ENDIF 
    8782 
    88          IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    89          IF( ln_crs_top ) THEN ;    CALL trc_ldf_crs( kstp ) 
    90          ELSE              ;    CALL trc_ldf( kstp ) 
     83         IF( ln_zps ) THEN 
     84           IF( ln_crs_top ) THEN 
     85              CALL zps_hde_crs( kstp, jptra, trn, gtru, gtrv ) 
     86           ELSE 
     87              IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kstp, jptra, trb, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )  ! both top & bottom 
     88              ELSE                 ; CALL zps_hde    ( kstp, jptra, trb, gtru, gtrv )                                      !  only bottom 
     89              ENDIF 
     90           ENDIF 
     91         ENDIF 
     92 
     93         IF( ln_crs_top ) THEN    ;    CALL trc_ldf_crs( kstp ) 
     94         ELSE                     ;    CALL trc_ldf( kstp ) 
    9195         ENDIF 
    9296         IF( .NOT. lk_offline .AND. lk_zdfkpp )    & 
    93             &                   CALL trc_kpp( kstp )            ! KPP non-local tracer fluxes 
     97            &                          CALL trc_kpp( kstp )            ! KPP non-local tracer fluxes 
    9498#if defined key_agrif 
    9599         IF(.NOT. Agrif_Root()) CALL Agrif_Sponge_trc           ! tracers sponge 
    96100#endif 
    97          IF( ln_crs_top ) THEN ;    CALL trc_zdf_crs( kstp ) 
    98          ELSE              ;    CALL trc_zdf( kstp ) 
     101         IF( ln_crs_top ) THEN    ;    CALL trc_zdf_crs( kstp ) 
     102         ELSE                     ;    CALL trc_zdf( kstp ) 
    99103         ENDIF 
    100  
    101                                 CALL trc_nxt( kstp )            ! tracer fields at next time step      
    102          IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
     104         ! 
     105                                       CALL trc_nxt( kstp )            ! tracer fields at next time step      
     106         IF( ln_trcrad )               CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
     107         IF( ln_trcdmp_clo )           CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    103108 
    104109#if defined key_agrif 
    105110      IF( .NOT. Agrif_Root())   CALL Agrif_Update_Trc( kstp )   ! Update tracer at AGRIF zoom boundaries : children only 
    106111#endif 
    107           ! Partial steps: now horizontal gradient of passive 
    108          IF( ln_zps    )THEN 
    109             IF( ln_crs_top ) THEN   
    110                CALL zps_hde_crs( kstp, jptra, trn, gtru, gtrv ) 
    111             ELSE 
    112                IF( ln_isfcav )THEN 
    113                   CALL zps_hde_isf( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )  ! Partial steps: now horizontal gradient of passive 
    114                ELSE 
    115                   CALL zps_hde    ( kstp, jptra, trn, gtru, gtrv )   ! Partial steps: now horizontal gradient of passive 
    116                ENDIF 
    117             ENDIF 
    118          ENDIF 
    119                                                                 ! tracers at the bottom ocean level 
    120          ! 
     112 
    121113      ELSE                                               ! 1D vertical configuration 
    122114                                CALL trc_sbc( kstp )            ! surface boundary condition 
    … …  
    130122      ! 
    131123      IF( nn_timing == 1 )   CALL timing_stop('trc_trp') 
     124      ! 
     1259400  FORMAT(a25,i4,D23.16) 
    132126      ! 
    133127   END SUBROUTINE trc_trp 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r7210 r7256  
    219219   USE crs , ONLY :  ahtw     =>   ahtw_crs        !: lateral diffusivity coef. at w-points  
    220220   USE crs , ONLY :  ahtt     =>   ahtt_crs        !: lateral diffusivity coef. at t-points 
     221   USE crs , ONLY :  r_fact_lap     =>  r_fact_lap_crs        !: enhanced zonal diffusivity coefficient 
    221222   USE ldftra_oce , ONLY :  rldf     =>   rldf 
    222223   USE crs , ONLY :  trc_i => trc_i_crs 
    … …  
    459460   USE ldftra_oce , ONLY :  aeiw     =>   aeiw        !: eddy induced velocity coef. at w-points (m2/s)  
    460461   USE ldftra_oce , ONLY :  lk_traldf_eiv  =>  lk_traldf_eiv     !: eddy induced velocity flag 
     462   USE ldftra_oce , ONLY :  r_fact_lap     =>  r_fact_lap        !: enhanced zonal diffusivity coefficient 
    461463 
    462464   !* vertical diffusion * 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r6772 r7256  
    7777      ALLOCATE( n_trc_index(ntrc), slf_i(ntrc), STAT=ierr0 ) 
    7878      IF( ierr0 > 0 ) THEN 
    79          CALL ctl_stop( 'trc_nam: unable to allocate n_trc_index' )   ;   RETURN 
     79         CALL ctl_stop( 'trc_dta_init: unable to allocate n_trc_index' )   ;   RETURN 
    8080      ENDIF 
    8181      nb_trcdta      = 0 
    … …  
    9191      IF(lwp) THEN 
    9292         WRITE(numout,*) ' ' 
     93         WRITE(numout,*) 'trc_dta_init : Passive tracers Initial Conditions ' 
     94         WRITE(numout,*) '~~~~~~~~~~~~~~ ' 
    9395         WRITE(numout,*) ' number of passive tracers to be initialize by data :', ntra 
    9496         WRITE(numout,*) ' ' 
    … …  
    107109         DO jn = 1, ntrc 
    108110            IF( ln_trc_ini(jn) )  THEN    ! open input file only if ln_trc_ini(jn) is true 
    109                clndta = TRIM( sn_trcdta(jn)%clvar )  
    110                clntrc = TRIM( ctrcnm   (jn)       )  
     111               clndta = TRIM( sn_trcdta(jn)%clvar ) 
     112               if (jn > jptra) then 
     113                  clntrc='Dummy' ! By pass weird formats in ocean.output if ntrc > jptra 
     114               else 
     115                  clntrc = TRIM( ctrcnm   (jn)       ) 
     116               endif 
    111117               zfact  = rn_trfac(jn) 
    112                IF( clndta /=  clntrc ) THEN  
    113                   CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation :  ',   & 
    114                   &              'the variable name in the data file : '//clndta//   &  
    115                   &              '  must be the same than the name of the passive tracer : '//clntrc//' ') 
     118               IF( clndta /=  clntrc ) THEN 
     119                  CALL ctl_warn( 'trc_dta_init: passive tracer data initialisation    ',   & 
     120                  &              'Input name of data file : '//TRIM(clndta)//   & 
     121                  &              ' differs from that of tracer : '//TRIM(clntrc)//' ') 
    116122               ENDIF 
    117                WRITE(numout,*) ' read an initial file for passive tracer number :', jn, ' name : ', clndta, &  
    118                &               ' multiplicative factor : ', zfact 
     123               WRITE(numout,'(a, i4,3a,e11.3)') ' Read IC file for tracer number :', & 
     124               &            jn, ', name : ', TRIM(clndta), ', Multiplicative Scaling factor : ', zfact 
    119125            ENDIF 
    120126         END DO 
    … …  
    124130         ALLOCATE( sf_trcdta(nb_trcdta), rf_trfac(nb_trcdta), STAT=ierr1 ) 
    125131         IF( ierr1 > 0 ) THEN 
    126             CALL ctl_stop( 'trc_dta_ini: unable to allocate  sf_trcdta structure' )   ;   RETURN 
     132            CALL ctl_stop( 'trc_dta_init: unable to allocate  sf_trcdta structure' )   ;   RETURN 
    127133         ENDIF 
    128134         ! 
    … …  
    135141               IF( sn_trcdta(jn)%ln_tint )  ALLOCATE( sf_trcdta(jl)%fdta(jpi,jpj,jpk,2) , STAT=ierr3 ) 
    136142               IF( ierr2 + ierr3 > 0 ) THEN 
    137                  CALL ctl_stop( 'trc_dta : unable to allocate passive tracer data arrays' )   ;   RETURN 
     143                 CALL ctl_stop( 'trc_dta_init : unable to allocate passive tracer data arrays' )   ;   RETURN 
    138144               ENDIF 
    139145            ENDIF 
    … …  
    141147         ENDDO 
    142148         !                         ! fill sf_trcdta with slf_i and control print 
    143          CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta', 'Passive tracer data', 'namtrc' ) 
     149         CALL fld_fill( sf_trcdta, slf_i, cn_dir, 'trc_dta_init', 'Passive tracer data', 'namtrc' ) 
    144150         ! 
    145151      ENDIF 
    … …  
    151157 
    152158 
    153    SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac ) 
     159   SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc) 
    154160      !!---------------------------------------------------------------------- 
    155161      !!                   ***  ROUTINE trc_dta  *** 
    … …  
    164170      !!---------------------------------------------------------------------- 
    165171      INTEGER                     , INTENT(in   ) ::   kt     ! ocean time-step 
    166       TYPE(FLD), DIMENSION(1)   , INTENT(inout) ::   sf_dta     ! array of information on the field to read 
    167       REAL(wp)                  , INTENT(in   ) ::   zrf_trfac  ! multiplication factor 
     172      TYPE(FLD), DIMENSION(1)     , INTENT(inout) ::   sf_dta     ! array of information on the field to read 
     173      REAL(wp)                    , INTENT(in   ) ::   ptrfac  ! multiplication factor 
     174      REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL  , INTENT(out  ) ::   ptrc 
    168175      ! 
    169176      INTEGER ::   ji, jj, jk, jl, jkk, ik    ! dummy loop indices 
    170177      REAL(wp)::   zl, zi 
    171178      REAL(wp), DIMENSION(jpk) ::  ztp                ! 1D workspace 
     179      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta   ! 3D  workspace 
    172180      CHARACTER(len=100) :: clndta 
    173181      !!---------------------------------------------------------------------- 
    … …  
    177185      IF( nb_trcdta > 0 ) THEN 
    178186         ! 
     187         CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )    ! Memory allocation 
     188         ! 
    179189         CALL fld_read( kt, 1, sf_dta )      !==   read data at kt time step   ==! 
     190         ztrcdta(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:)    ! Mask 
    180191         ! 
    181192         IF( ln_sco ) THEN                   !==   s- or mixed s-zps-coordinate   ==! 
    … …  
    186197            ENDIF 
    187198            ! 
    188                DO jj = 1, jpj                         ! vertical interpolation of T & S 
     199            DO jj = 1, jpj                         ! vertical interpolation of T & S 
     200               DO ji = 1, jpi 
     201                  DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
     202                     zl = fsdept_n(ji,jj,jk) 
     203                     IF(     zl < gdept_1d(1  ) ) THEN         ! above the first level of data 
     204                        ztp(jk) = ztrcdta(ji,jj,1) 
     205                     ELSEIF( zl > gdept_1d(jpk) ) THEN         ! below the last level of data 
     206                        ztp(jk) =  ztrcdta(ji,jj,jpkm1) 
     207                     ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
     208                        DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
     209                           IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
     210                              zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
     211                              ztp(jk) = ztrcdta(ji,jj,jkk) + ( ztrcdta(ji,jj,jkk+1) - & 
     212                                        ztrcdta(ji,jj,jkk) ) * zi  
     213                           ENDIF 
     214                        END DO 
     215                     ENDIF 
     216                  END DO 
     217                  DO jk = 1, jpkm1 
     218                    ztrcdta(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk)     ! mask required for mixed zps-s-coord 
     219                  END DO 
     220                  ztrcdta(ji,jj,jpk) = 0._wp 
     221                END DO 
     222            END DO 
     223            !  
     224         ELSE                                !==   z- or zps- coordinate   ==! 
     225            ! 
     226            IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
     227               DO jj = 1, jpj 
    189228                  DO ji = 1, jpi 
    190                      DO jk = 1, jpk                        ! determines the intepolated T-S profiles at each (i,j) points 
    191                         zl = fsdept_n(ji,jj,jk) 
    192                         IF(     zl < gdept_1d(1  ) ) THEN         ! above the first level of data 
    193                            ztp(jk) =  sf_dta(1)%fnow(ji,jj,1) 
    194                         ELSEIF( zl > gdept_1d(jpk) ) THEN         ! below the last level of data 
    195                            ztp(jk) =  sf_dta(1)%fnow(ji,jj,jpkm1) 
    196                         ELSE                                      ! inbetween : vertical interpolation between jkk & jkk+1 
    197                            DO jkk = 1, jpkm1                                  ! when  gdept(jkk) < zl < gdept(jkk+1) 
    198                               IF( (zl-gdept_1d(jkk)) * (zl-gdept_1d(jkk+1)) <= 0._wp ) THEN 
    199                                  zi = ( zl - gdept_1d(jkk) ) / (gdept_1d(jkk+1)-gdept_1d(jkk)) 
    200                                  ztp(jk) = sf_dta(1)%fnow(ji,jj,jkk) + ( sf_dta(1)%fnow(ji,jj,jkk+1) - & 
    201                                            sf_dta(1)%fnow(ji,jj,jkk) ) * zi  
    202                               ENDIF 
    203                            END DO 
    204                         ENDIF 
    205                      END DO 
    206                      DO jk = 1, jpkm1 
    207                         sf_dta(1)%fnow(ji,jj,jk) = ztp(jk) * tmask(ji,jj,jk)     ! mask required for mixed zps-s-coord 
    208                      END DO 
    209                      sf_dta(1)%fnow(ji,jj,jpk) = 0._wp 
     229                     ik = mbkt(ji,jj)  
     230                     IF( ik > 1 ) THEN 
     231                        zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
     232                        ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik-1) 
     233                     ENDIF 
     234                     ik = mikt(ji,jj) 
     235                     IF( ik > 1 ) THEN 
     236                        zl = ( fsdept_n(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
     237                        ztrcdta(ji,jj,ik) = (1.-zl) * ztrcdta(ji,jj,ik) + zl * ztrcdta(ji,jj,ik+1) 
     238                     ENDIF 
    210239                  END DO 
    211240               END DO 
    212             !  
    213          ELSE                                !==   z- or zps- coordinate   ==! 
    214             !                              
    215                sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * tmask(:,:,:)    ! Mask 
    216                ! 
    217                IF( ln_zps ) THEN                      ! zps-coordinate (partial steps) interpolation at the last ocean level 
    218                   DO jj = 1, jpj 
    219                      DO ji = 1, jpi 
    220                         ik = mbkt(ji,jj)  
    221                         IF( ik > 1 ) THEN 
    222                            zl = ( gdept_1d(ik) - fsdept_n(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) 
    223                            sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik-1) 
    224                         ENDIF 
    225                         ik = mikt(ji,jj) 
    226                         IF( ik > 1 ) THEN 
    227                            zl = ( gdept_0(ji,jj,ik) - gdept_1d(ik) ) / ( gdept_1d(ik+1) - gdept_1d(ik) ) 
    228                            sf_dta(1)%fnow(ji,jj,ik) = (1.-zl) * sf_dta(1)%fnow(ji,jj,ik) + zl * sf_dta(1)%fnow(ji,jj,ik+1) 
    229                         ENDIF 
    230                      END DO 
    231                   END DO 
    232                ENDIF 
    233             ! 
    234          ENDIF 
    235          ! 
    236          sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * zrf_trfac   !  multiplicative factor 
     241            ENDIF 
     242            ! 
     243         ENDIF 
     244         ! 
     245         ! Add multiplicative factor 
     246         ztrcdta(:,:,:) = ztrcdta(:,:,:) * ptrfac 
     247         ! 
     248         ! Data structure for trc_ini (and BFMv5.1 coupling) 
     249         IF( .NOT. PRESENT(ptrc) ) sf_dta(1)%fnow(:,:,:) = ztrcdta(:,:,:) 
     250         ! 
     251         ! Data structure for trc_dmp 
     252         IF( PRESENT(ptrc) )  ptrc(:,:,:) = ztrcdta(:,:,:) 
    237253         ! 
    238254         IF( lwp .AND. kt == nit000 ) THEN 
    … …  
    241257               WRITE(numout,*) 
    242258               WRITE(numout,*)'  level = 1' 
    243                CALL prihre( sf_dta(1)%fnow(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     259               CALL prihre( ztrcdta(:,:,1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    244260               WRITE(numout,*)'  level = ', jpk/2 
    245                CALL prihre( sf_dta(1)%fnow(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     261               CALL prihre( ztrcdta(:,:,jpk/2), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    246262               WRITE(numout,*)'  level = ', jpkm1 
    247                CALL prihre( sf_dta(1)%fnow(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
     263               CALL prihre( ztrcdta(:,:,jpkm1), jpi, jpj, 1, jpi, 20, 1, jpj, 20, 1., numout ) 
    248264               WRITE(numout,*) 
    249265         ENDIF 
     266         ! 
     267         CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
     268         ! 
    250269      ENDIF 
    251270      ! 
    … …  
    258277   !!---------------------------------------------------------------------- 
    259278CONTAINS 
    260    SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac )        ! Empty routine 
     279   SUBROUTINE trc_dta( kt, sf_dta, ptrfac, ptrc)        ! Empty routine 
    261280      WRITE(*,*) 'trc_dta: You should not have seen this print! error?', kt 
    262281   END SUBROUTINE trc_dta 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r7217 r7256  
    2525   USE trcini_my_trc   ! MY_TRC   initialisation 
    2626   USE trcdta          ! initialisation from files 
    27    USE zpshde,ONLY: zps_hde, zps_hde_isf    ! partial step: hor. derivative   (zps_hde routine) 
    28    USE zpshde_crs      ! partial step: hor. derivative   (zps_hde routine) 
     27   USE daymod          ! calendar manager 
    2928   USE prtctl_trc      ! Print control passive tracers (prt_ctl_trc_init routine) 
    3029   USE trcsub          ! variables to substep passive tracers 
    … …  
    6362      INTEGER ::   jk, jn, jl    ! dummy loop indices 
    6463      CHARACTER (len=25) :: charout 
    65       REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta   ! 4D  workspace 
    6664      !!--------------------------------------------------------------------- 
    6765      ! 
    … …  
    123121        IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN  ! Initialisation of tracer from a file that may also be used for damping 
    124122            ! 
    125             CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )    ! Memory allocation 
    126             ! 
    127123            DO jn = 1, jptra 
    128124               IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    129125                  jl = n_trc_index(jn)  
    130                   CALL trc_dta( nit000, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
    131                   ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
    132                   trn(:,:,:,jn) = ztrcdta(:,:,:) * tmask(:,:,:)   
     126                  CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) )   ! read tracer data at nit000 
     127                  trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:)  
    133128                  IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN      !== deallocate data structure   ==! 
    134129                     !                                                    (data used only for initialisation) 
    … …  
    140135               ENDIF 
    141136            ENDDO 
    142             CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
     137            ! 
    143138        ENDIF 
    144139        ! 
    … …  
    148143  
    149144      tra(:,:,:,:) = 0._wp 
    150       IF( ln_crs_top)  THEN 
    151          CALL zps_hde_crs( nit000, jptra, trn, gtru, gtrv ) 
    152       ELSE 
    153          IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav )   &              ! Partial steps: before horizontal gradient of passive 
    154          &    CALL zps_hde    ( nit000, jptra, trn, gtru, gtrv  )  ! Partial steps: before horizontal gradient 
    155          IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav )   & 
    156          &    CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )       ! tracers at the bottom ocean level 
    157       ENDIF 
    158  
    159145      ! 
    160146      IF( nn_dttrc /= 1 )        CALL trc_sub_ini      ! Initialize variables for substepping passive tracers 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

    r5602 r7256  
    397397   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    398398   !!====================================================================== 
    399 END MODULE  trcnam 
     399END MODULE trcnam 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcrst.F90

    r5602 r7256  
    307307         IF(lwp) WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), zmean, zmin, zmax, zdrift 
    308308      END DO 
    309       WRITE(numout,*)  
     309      IF(lwp) WRITE(numout,*)  
    3103109000  FORMAT(' tracer nb :',i2,'    name :',a10,'    mean :',e18.10,'    min :',e18.10, & 
    311311      &      '    max :',e18.10,'    drift :',e18.10, ' %') 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsms.F90

    r3680 r7256  
    7575 
    7676   !!====================================================================== 
    77 END MODULE  trcsms 
     77END MODULE trcsms 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r7222 r7256  
    2020   USE trdtrc_oce 
    2121   USE trdmxl_trc 
    22    USE iom, ONLY : lk_iomput , iom_close 
     22   USE iom, ONLY : lk_iomput , iom_close, iom_varid, jpdom_autoglo, iom_get, iom_rstput 
    2323   USE in_out_manager 
    2424   USE trcsub 
    … …  
    3333   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr ! save qsr during TOP time-step 
    3434   REAL(wp) :: rdt_sampl 
    35    INTEGER  :: nb_rec_per_days 
    36    INTEGER  :: isecfst, iseclast 
     35   INTEGER  :: nb_rec_per_day 
     36   REAL(wp) :: rsecfst, rseclast 
    3737   LOGICAL  :: llnew 
    3838 
    … …  
    6060      REAL(wp)              ::  ztrai 
    6161      CHARACTER (len=25)    ::  charout  
    62  
    6362      !!------------------------------------------------------------------- 
    6463      ! 
    … …  
    9594                                   CALL trc_sms      ( kt )       ! tracers: sinks and sources 
    9695                                   CALL trc_trp      ( kt )       ! transport of passive tracers 
     96 
    9797         IF( kt == nittrc000 ) THEN 
    9898            CALL iom_close( numrtr )       ! close input tracer restart file 
    … …  
    106106      ENDIF 
    107107      ! 
     108 
    108109      ztrai = 0._wp                                                   !  content of all tracers 
    109110      DO jn = 1, jptra 
    … …  
    111112      END DO 
    112113      IF( lwp ) WRITE(numstr,9300) kt,  ztrai / areatot 
    113 9300  FORMAT(i10,e18.10) 
     1149300  FORMAT(i10,D23.16) 
    114115      ! 
    115116      IF( nn_timing == 1 )   CALL timing_stop('trc_stp') 
    … …  
    124125      !!               of diurnal cycle 
    125126      !! 
    126       !! ** Method  : store in TOP the qsr every hour ( or every time-step the latter  
     127      !! ** Method  : store in TOP the qsr every hour ( or every time-step if the latter  
    127128      !!              is greater than 1 hour ) and then, compute the  mean with  
    128129      !!              a moving average over 24 hours.  
    … …  
    131132      INTEGER, INTENT(in) ::   kt 
    132133      INTEGER  :: jn 
     134      REAL(wp) :: zkt 
     135      CHARACTER(len=1)               ::   cl1                      ! 1 character 
     136      CHARACTER(len=2)               ::   cl2                      ! 2 characters 
    133137 
    134138      IF( kt == nit000 ) THEN 
    135139         IF( ln_cpl )  THEN   
    136             rdt_sampl = 86400. / ncpl_qsr_freq 
    137             nb_rec_per_days = ncpl_qsr_freq 
     140            rdt_sampl = rday / ncpl_qsr_freq 
     141            nb_rec_per_day = ncpl_qsr_freq 
    138142         ELSE   
    139             rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 
    140             nb_rec_per_days = INT( 86400 / rdt_sampl ) 
     143            rdt_sampl = MAX( 3600., rdttrc(1) ) 
     144            nb_rec_per_day = INT( rday / rdt_sampl ) 
    141145         ENDIF 
    142146         ! 
    143147         IF( lwp ) THEN 
    144148            WRITE(numout,*)  
    145             WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_days 
     149            WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_day 
    146150            WRITE(numout,*)  
    147151         ENDIF 
    148152         ! 
    149          ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_days ) ) 
    150          DO jn = 1, nb_rec_per_days 
    151             qsr_arr(:,:,jn) = qsr(:,:) 
    152          ENDDO 
    153          qsr_mean(:,:) = qsr(:,:) 
    154          ! 
    155          isecfst  = nsec_year + nsec1jan000   !   number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
    156          iseclast = isecfst 
    157          ! 
    158       ENDIF 
    159       ! 
    160       iseclast = nsec_year + nsec1jan000 
    161       llnew   = ( iseclast - isecfst )  > INT( rdt_sampl )   !   new shortwave to store 
    162       IF( kt /= nittrc000 .AND. llnew ) THEN 
     153         ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) 
     154         ! 
     155         !                                            !* Restart: read in restart file 
     156         IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 .AND. & 
     157                            iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 .AND. & 
     158                            iom_varid( numrtr, 'ktdcy'    , ldstop = .FALSE. ) > 0 ) THEN  
     159            CALL iom_get( numrtr, 'ktdcy', zkt )   !  A mean of qsr 
     160            rsecfst = INT( zkt ) * rdttrc(1) 
     161            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' 
     162            CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean )   !  A mean of qsr 
     163            DO jn = 1, nb_rec_per_day  
     164             IF( jn <= 9 )  THEN 
     165               WRITE(cl1,'(i1)') jn 
     166               CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) )   !  A mean of qsr 
     167             ELSE 
     168               WRITE(cl2,'(i2.2)') jn 
     169               CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) )   !  A mean of qsr 
     170             ENDIF 
     171           ENDDO 
     172         ELSE                                         !* no restart: set from nit000 values 
     173            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean set to nit000 values' 
     174            rsecfst  = kt * rdttrc(1) 
     175            ! 
     176            qsr_mean(:,:) = qsr(:,:) 
     177            DO jn = 1, nb_rec_per_day 
     178               qsr_arr(:,:,jn) = qsr_mean(:,:) 
     179            ENDDO 
     180         ENDIF 
     181         ! 
     182      ENDIF 
     183      ! 
     184      rseclast = kt * rdttrc(1) 
     185      ! 
     186      llnew   = ( rseclast - rsecfst ) .ge.  rdt_sampl    !   new shortwave to store 
     187      IF( llnew ) THEN 
    163188          IF( lwp ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', kt, & 
    164              &                      ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 
    165           isecfst = iseclast 
    166           DO jn = 1, nb_rec_per_days - 1 
     189             &                      ' time = ', rseclast/3600.,'hours ' 
     190          rsecfst = rseclast 
     191          DO jn = 1, nb_rec_per_day - 1 
    167192             qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 
    168193          ENDDO 
    169           qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 
    170           qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days 
     194          qsr_arr (:,:,nb_rec_per_day) = qsr(:,:) 
     195          qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day 
     196      ENDIF 
     197      ! 
     198      IF( lrst_trc ) THEN    !* Write the mean of qsr in restart file  
     199         IF(lwp) WRITE(numout,*) 
     200         IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file  kt =', kt 
     201         IF(lwp) WRITE(numout,*) '~~~~~~~' 
     202         zkt = REAL( kt, wp ) 
     203         CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) 
     204          DO jn = 1, nb_rec_per_day  
     205             IF( jn <= 9 )  THEN 
     206               WRITE(cl1,'(i1)') jn 
     207               CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) 
     208             ELSE 
     209               WRITE(cl2,'(i2.2)') jn 
     210               CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) 
     211             ENDIF 
     212         ENDDO 
     213         CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) 
    171214      ENDIF 
    172215      ! 

  • branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcsub.F90

    r6772 r7256  
    1616   USE iom_def, ONLY : jprstlib 
    1717   USE lbclnk 
    18 !#if defined key_zdftke 
    19 !   USE zdftke          ! twice TKE (en) 
    20 !#endif 
    21 #if defined key_zdfgls 
    22    USE zdfgls, ONLY: en 
    23 #endif 
    24 !   USE trabbl 
    25 !   USE zdf_oce 
    26 !   USE domvvl 
    27    USE divcur, ONLY : div_cur           ! hor. divergence and curl      (div & cur routines) 
     18   !cbr USE trabbl 
     19   !cbr USE zdf_oce 
     20   !cbr USE domvvl 
     21   USE divcur, ONLY : div_cur        ! hor. divergence and curl      (div & cur routines) 
    2822   USE sbcrnf, ONLY: h_rnf, nk_rnf   ! River runoff  
    2923   USE bdy_oce 
Note: See TracChangeset for help on using the changeset viewer.