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 6851 for branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO – NEMO

Ignore:
Timestamp:
2016-08-08T10:34:39+02:00 (8 years ago)
Author:
gm
Message:

#1629: SIMPLIF_1: S-EOS + DOC and phasing with trunk rev6826

Location:
branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO
Files:
58 edited

Legend:

Unmodified
Added
Removed

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r5341 r6851  
    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 
    … …  
    253252   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    254253 
    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] 
     254   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange   [kg.m-2.s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice  [kg.m-2.s-1] 
     256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow/ice sublimation       [kg.m-2.s-1] 
     257 
     258   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange                   [kg.m-2.s-1] 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice      [kg.m-2.s-1] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
     262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice          [kg.m-2.s-1] 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice         [kg.m-2.s-1] 
     265   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice             [kg.m-2.s-1] 
     266 
     267   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1] 
    269268   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] 
     269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics)       [s-1] 
    271270 
    272271   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    279278   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s] 
    280279 
    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  
     280   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation 
     281 
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2] 
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2] 
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2] 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2] 
     286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2] 
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2] 
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion             [W.m-2] 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2] 
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2] 
     292   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2] 
     293   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 
     294    
    293295   ! 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  
     296   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2] 
     297   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
    296298 
    297299   ! 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 
     300   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  [W.m-2] 
     301   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  [W.m-2] 
     302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
     303 
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice    
     305   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   pahu3D , pahv3D 
     306   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    303307 
    304308   !!-------------------------------------------------------------------------- 
    … …  
    369373   !!-------------------------------------------------------------------------- 
    370374   !                                                  !!: ** Namelist namicerun read in sbc_lim_init ** 
    371    INTEGER          , PUBLIC ::   jpl             !: number of ice  categories  
    372    INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
    373    INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
    374    CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     375   INTEGER           , PUBLIC ::   jpl             !: number of ice  categories  
     376   INTEGER           , PUBLIC ::   nlay_i          !: number of ice  layers  
     377   INTEGER           , PUBLIC ::   nlay_s          !: number of snow layers  
     378   CHARACTER(len=32) , PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    375379   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) 
     380   CHARACTER(len=32) , PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    377381   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
    378    LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    379    LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
    380    REAL(wp)         , PUBLIC ::   rn_amax         !: maximum ice concentration 
    381    INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
    382    INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
     382   LOGICAL           , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
     383   LOGICAL           , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
     384   REAL(wp)          , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
     385   REAL(wp)          , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
     386   INTEGER           , PUBLIC ::   iiceprt         !: debug i-point 
     387   INTEGER           , PUBLIC ::   jiceprt         !: debug j-point 
    383388   ! 
    384389   !!-------------------------------------------------------------------------- 
    … …  
    424429      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) ,                           & 
    425430         &      ahiu     (jpi,jpj) , ahiv     (jpi,jpj) ,                           & 
    426          &      pahu     (jpi,jpj) , pahv     (jpi,jpj) ,                           & 
    427431         &      ust2s    (jpi,jpj) , hicol    (jpi,jpj) ,                           & 
    428432         &      strp1    (jpi,jpj) , strp2    (jpi,jpj) , strength  (jpi,jpj) ,     & 
    … …  
    437441         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
    438442         &      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) ,                        & 
     443         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1),            & 
     444         &      rn_amax_2d (jpi,jpj) , qlead  (jpi,jpj) ,                                                         & 
     445         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj),                        & 
    441446         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    442447         &      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) ,                                   & 
     448         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,       & 
    444449         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
    445450         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 
    … …  
    508513   !!====================================================================== 
    509514END MODULE ice 
     515 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r5836 r6851  
    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            &                ) *  e1e2t(:,:) * 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            &              ) * e1e2t(:,:) * 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 ) * e1e2t * tmask(:,:,1) * zconv )  
     290      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - SUM( qevap_ice * a_i_b, dim=3 ) )  & 
     291         &              * e1e2t * tmask(:,:,1) * zconv )  
    289292      ! salt flux 
    290293      zsfx  = glob_sum( ( sfx + diag_smvi ) * e1e2t * tmask(:,:,1) * zconv ) * rday 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r5836 r6851  
    5656      real(wp)   ::   zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 
    5757      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  
     58      &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub  
    5959      real(wp)   ::   zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 
    6060      real(wp)   ::   zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub   
    … …  
    111111      zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
    112112      zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
     113      zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e1e2t(:,:) * tmask(:,:,1) ) 
    113114 
    114115      ! Heat budget 
    115       zbg_ihc      = glob_sum( et_i(:,:) * e1e2t(:,:) ) * 1.e-20 ! ice heat content  [1.e20 J] 
    116       zbg_shc      = glob_sum( et_s(:,:) * e1e2t(:,:) ) * 1.e-20 ! snow heat content [1.e20 J] 
     116      zbg_ihc      = glob_sum( et_i(:,:) * e1e2t(:,:) * 1.e-20 ) ! ice heat content  [1.e20 J] 
     117      zbg_shc      = glob_sum( et_s(:,:) * e1e2t(:,:) * 1.e-20 ) ! snow heat content [1.e20 J] 
    117118      zbg_hfx_dhc  = glob_sum( diag_heat(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] 
    118119      zbg_hfx_spr  = glob_sum( hfx_spr(:,:) * e1e2t(:,:) * tmask(:,:,1) ) ! [in W] 
    … …  
    189190      CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom                              )   ! salt flux bottom melt       - 
    190191      CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum                              )   ! salt flux surface melt      - 
     192      CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub                              )   ! salt flux sublimation      - 
    191193 
    192194      CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc                              )   ! Heat content variation in snow and ice [W] 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r5836 r6851  
    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_init    ! called by sbc_lim_init 
     30   PUBLIC   lim_hdf        ! called by lim_trp 
     31   PUBLIC   lim_hdf_init   ! called by sbc_lim_init 
    3132 
    3233   LOGICAL  ::   linit = .TRUE.                             ! initialization flag (set to flase after the 1st call) 
    … …  
    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_e1e2t(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_e1e2t(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         IF ( MOD( iter-1 , nn_convfrq ) == 0 )  THEN   !Convergence test every nn_convfrq iterations (perf. optimization )  
     162            DO jk=1,isize 
     163               zconv(jk) = 0._wp                                   ! convergence test 
     164               DO jj = 2, jpjm1 
     165                  DO ji = fs_2, fs_jpim1 
     166                     zconv(jk) = MAX( zconv(jk), ABS( zrlx(ji,jj,jk) - ptab(ji,jj,jk) )  ) 
     167                  END DO 
     168               END DO 
     169            END DO 
     170            IF( lk_mpp ) CALL mpp_max_multiple( zconv , isize )            ! max over the global domain for all the variables 
     171         ENDIF 
     172         ! 
     173         DO jk=1,isize 
     174            ptab(:,:,jk) = zrlx(:,:,jk) 
     175         END DO 
     176         ! 
     177      END DO                                       ! end of sub-time step loop 
     178 
     179     ! ----------------------- 
     180      !!! final step (clem) !!! 
     181      DO jk = 1, isize 
     182         jl = (jk-1) /( ihdf_vars+nlay_i)+1 
    100183         DO jj = 1, jpjm1                                ! diffusive fluxes in U- and V- direction 
    101184            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) ) 
     185               zflu(ji,jj) = pahu3D(ji,jj,jl) * e2u(ji,jj) * r1_e1u(ji,jj) * ( ptab(ji+1,jj,jk) - ptab(ji,jj,jk) ) 
     186               zflv(ji,jj) = pahv3D(ji,jj,jl) * e1v(ji,jj) * r1_e2v(ji,jj) * ( ptab(ji,jj+1,jk) - ptab(ji,jj,jk) ) 
    104187            END DO 
    105188         END DO 
    … …  
    108191            DO ji = fs_2 , fs_jpim1   ! vector opt.  
    109192               zdiv(ji,jj) = ( zflu(ji,jj) - zflu(ji-1,jj) + zflv(ji,jj) - zflv(ji,jj-1) ) * r1_e1e2t(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) ) 
     193               ptab(ji,jj,jk) = ztab0(ji,jj,jk) + 0.5 * ( zdiv(ji,jj) + zdiv0(ji,jj,jk) ) 
     194            END DO 
    146195         END DO 
    147196      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_e1e2t(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 
     197 
     198      CALL lbc_lnk_multi( pt2d_array, type_array , psgn_array , isize ) ! Multiple interchange of all the variables 
     199 
    156200      !!! final step (clem) !!! 
    157201      ! ----------------------- 
    158202 
    159203      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 ) 
     204         DO jk = 1 , isize 
     205            zrlx(:,:,jk) = ptab(:,:,jk) - ztab0(:,:,jk) 
     206            WRITE(charout,FMT="(' lim_hdf  : zconv =',D23.16, ' iter =',I4,2X)") zconv, iter 
     207            CALL prt_ctl( tab2d_1=zrlx(:,:,jk), clinfo1=charout ) 
     208         END DO 
     209      ENDIF 
     210      ! 
     211      CALL wrk_dealloc( jpi, jpj, isize, zrlx, zdiv0, ztab0 ) 
     212      CALL wrk_dealloc( jpi, jpj, zflu, zflv, zdiv ) 
     213 
     214      DEALLOCATE( zconv ) 
     215      DEALLOCATE( pt2d_array , zrlx_array ) 
     216      DEALLOCATE( type_array ) 
     217      DEALLOCATE( psgn_array ) 
    166218      ! 
    167219   END SUBROUTINE lim_hdf 
     220 
    168221 
    169222    
    … …  
    179232      !!------------------------------------------------------------------- 
    180233      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    181       NAMELIST/namicehdf/ nn_convfrq 
     234      NAMELIST/namicehdf/ nn_convfrq  
    182235      !!------------------------------------------------------------------- 
    183236      ! 
    … …  
    212265   !!====================================================================== 
    213266END MODULE limhdf 
     267 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r6347 r6851  
    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 
    … …  
    253254                           END DO 
    254255                           za_i_ini(ji,jj,i_fill)   = zat_i_ini(ji,jj) - zA ! ice conc in the last category 
    255                            IF ( i_fill .LT. jpl ) za_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
     256                           IF ( i_fill < jpl ) za_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
    256257          
    257258                           !--- Ice thickness in the last category 
    … …  
    261262                           END DO 
    262263                           zh_i_ini(ji,jj,i_fill) = ( zvt_i_ini(ji,jj) - zV ) / za_i_ini(ji,jj,i_fill)  
    263                            IF ( i_fill .LT. jpl ) zh_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
     264                           IF ( i_fill < jpl ) zh_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
    264265 
    265266                           !--- volumes 
    266267                           zv_i_ini(ji,jj,:) = za_i_ini(ji,jj,:) * zh_i_ini(ji,jj,:) 
    267                            IF ( i_fill .LT. jpl ) zv_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
     268                           IF ( i_fill < jpl ) zv_i_ini(ji,jj,i_fill+1:jpl) = 0._wp 
    268269 
    269270                        ENDIF ! i_fill 
    … …  
    273274                        !--------------------- 
    274275                        ! Test 1: area conservation 
    275                         zA_cons = SUM( za_i_ini(ji,jj,:) ) 
    276                         zconv   = ABS( zat_i_ini(ji,jj) - zA_cons ) 
    277                         IF ( zconv < 1.0e-6 ) THEN 
     276                        zA_cons = SUM( za_i_ini(ji,jj,:) )   ;   zconv = ABS( zat_i_ini(ji,jj) - zA_cons ) 
     277                        IF ( zconv < 1.e-6 ) THEN 
    278278                           ztest_1 = 1 
    279279                        ELSE  
    280                           ! this write is useful 
    281                           IF(lwp)  WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,   & 
    282                            &                                                    ' zat_i_ini = ',zat_i_ini(ji,jj) 
    283280                          ztest_1 = 0 
    284281                        ENDIF 
    285282 
    286283                        ! Test 2: volume conservation 
    287                         zV_cons = SUM( zv_i_ini(ji,jj,:) ) 
    288                         zconv   = ABS( zvt_i_ini(ji,jj) - zV_cons ) 
    289  
    290                         IF( zconv < 1.0e-6 ) THEN 
     284                        zV_cons = SUM(zv_i_ini(ji,jj,:)) 
     285                        zconv = ABS(zvt_i_ini(ji,jj) - zV_cons) 
     286 
     287                        IF( zconv < 1.e-6 ) THEN 
    291288                           ztest_2 = 1 
    292289                        ELSE 
    293                            ! this write is useful 
    294                            IF(lwp)  WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons,   & 
    295                               &                                                    ' zvt_i_ini = ', zvt_i_ini(ji,jj) 
    296290                           ztest_2 = 0 
    297291                        ENDIF 
    … …  
    301295                           ztest_3 = 1 
    302296                        ELSE 
    303                            ! this write is useful 
    304                            IF(lwp) WRITE(numout,*) ' * TEST3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** ',   & 
    305                               &    ' zh_i_ini(ji,jj,i_fill) = ', zh_i_ini(ji,jj,i_fill), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    306                            IF(lwp) WRITE(numout,*) ' ji,jj,i_fill ',ji,jj,i_fill 
    307                            IF(lwp) WRITE(numout,*) 'zht_i_ini ',zht_i_ini(ji,jj) 
    308297                           ztest_3 = 0 
    309298                        ENDIF 
    … …  
    312301                        ztest_4 = 1 
    313302                        DO jl = 1, jpl 
    314                            IF ( za_i_ini(ji,jj,jl) .LT. 0._wp ) THEN  
    315                               ! this write is useful 
    316                               IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(ji,jj,jl) 
     303                           IF ( za_i_ini(ji,jj,jl) < 0._wp ) THEN  
    317304                              ztest_4 = 0 
    318305                           ENDIF 
    … …  
    381368         END DO 
    382369 
     370         ! for constant salinity in time 
     371         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     372            CALL lim_var_salprof 
     373            smv_i = sm_i * v_i 
     374         ENDIF 
     375          
    383376         ! Snow temperature and heat content 
    384377         DO jk = 1, nlay_s 
    … …  
    531524      !!----------------------------------------------------------------------------- 
    532525      ! 
    533       REWIND( numnam_ice_ref )         ! Namelist namiceini in reference namelist : Ice initial state 
     526      REWIND( numnam_ice_ref )              ! Namelist namiceini in reference namelist : Ice initial state 
    534527      READ  ( numnam_ice_ref, namiceini, IOSTAT = ios, ERR = 901) 
    535528901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceini in reference namelist', lwp ) 
    536529 
    537       REWIND( numnam_ice_cfg )         ! Namelist namiceini in configuration namelist : Ice initial state 
     530      REWIND( numnam_ice_cfg )              ! Namelist namiceini in configuration namelist : Ice initial state 
    538531      READ  ( numnam_ice_cfg, namiceini, IOSTAT = ios, ERR = 902 ) 
    539532902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namiceini in configuration namelist', lwp ) 
    540533      IF(lwm) WRITE ( numoni, namiceini ) 
    541534 
    542       slf_i(jp_hti) = sn_hti   ;   slf_i(jp_hts) = sn_hts 
    543       slf_i(jp_ati) = sn_ati   ;   slf_i(jp_tsu) = sn_tsu 
    544       slf_i(jp_tmi) = sn_tmi   ;   slf_i(jp_smi) = sn_smi 
    545  
    546       IF(lwp) THEN                     ! control print 
     535      slf_i(jp_hti) = sn_hti  ;  slf_i(jp_hts) = sn_hts 
     536      slf_i(jp_ati) = sn_ati  ;  slf_i(jp_tsu) = sn_tsu 
     537      slf_i(jp_tmi) = sn_tmi  ;  slf_i(jp_smi) = sn_smi 
     538 
     539      ! Define the initial parameters 
     540      ! ------------------------- 
     541 
     542      IF(lwp) THEN 
    547543         WRITE(numout,*) 
    548544         WRITE(numout,*) 'lim_istate_init : ice parameters inititialisation ' 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r5836 r6851  
    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 )  
    … …  
    377298         CALL prt_ctl_info(' - Cell values : ') 
    378299         CALL prt_ctl_info('   ~~~~~~~~~~~~~ ') 
    379          CALL prt_ctl(tab2d_1=e1e2t, clinfo1=' lim_itd_me  : cell area :') 
     300         CALL prt_ctl(tab2d_1=e1e2t , clinfo1=' lim_itd_me  : cell area :') 
    380301         CALL prt_ctl(tab2d_1=at_i , clinfo1=' lim_itd_me  : at_i      :') 
    381302         CALL prt_ctl(tab2d_1=vt_i , clinfo1=' lim_itd_me  : vt_i      :') 
    … …  
    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 
    … …  
    511869            END DO 
    512870         END DO 
    513  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r5836 r6851  
    159159      CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    160160      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                 ) 
     161      CALL wrk_alloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    162162 
    163163#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    690690      CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    691691      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                 ) 
     692      CALL wrk_dealloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
    693693 
    694694   END SUBROUTINE lim_rhg 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r6140 r6851  
    107107      REAL(wp) ::   zqsr             ! New solar flux received by the ocean 
    108108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 3D workspace 
     109      REAL(wp), POINTER, DIMENSION(:,:)   ::   zalb                 ! 2D workspace 
    109110      !!--------------------------------------------------------------------- 
    110111      ! 
    111112      ! make calls for heat fluxes before it is modified 
     113      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
    112114      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    113115      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    … …  
    118120      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    119121         &                                                      * 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) 
     122      IF( iom_use('qemp_oce') )  CALL iom_put( "qemp_oce" , qemp_oce(:,:) )   
     123      IF( iom_use('qemp_ice') )  CALL iom_put( "qemp_ice" , qemp_ice(:,:) )   
     124      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) 
     125      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) 
     126 
     127      ! albedo output 
     128      CALL wrk_alloc( jpi,jpj, zalb )     
     129 
     130      zalb(:,:) = 0._wp 
     131      WHERE     ( SUM( a_i_b, dim=3 ) <= epsi06 )  ;  zalb(:,:) = 0.066_wp 
     132      ELSEWHERE                                    ;  zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 
     133      END WHERE 
     134      IF( iom_use('alb_ice' ) )  CALL iom_put( "alb_ice"  , zalb(:,:) )           ! ice albedo output 
     135 
     136      zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) )       
     137      IF( iom_use('albedo'  ) )  CALL iom_put( "albedo"  , zalb(:,:) )           ! ice albedo output 
     138 
     139      CALL wrk_dealloc( jpi,jpj, zalb )     
     140 
    124141      DO jj = 1, jpj 
    125142         DO ji = 1, jpi 
    … …  
    140157            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    141158 
    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) 
     159            ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
     160            !---------------------------------------------------------------------- 
     161            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   & 
     162               &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
    145163 
    146164            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    147             !--------------------------------------------------- 
     165            !---------------------------------------------------------------------------- 
    148166            qsr(ji,jj) = zqsr                                       
    149167            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    … …  
    165183 
    166184            ! 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              
     185            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 
     186            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)             
    170187         END DO 
    171188      END DO 
    … …  
    175192      !------------------------------------------! 
    176193      sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:)   & 
    177          &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 
     194         &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 
    178195 
    179196      !-------------------------------------------------------------! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r6140 r6851  
    440440      ! 
    441441      DO ji = kideb, kiut 
    442          zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
     442         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 
    443443         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
    444444            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
    … …  
    495495         ! 
    496496         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
     497         CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    497498         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    498499         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    524525         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    525526         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
     527         CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub         , jpi, jpj,npb(1:nbpb) ) 
    526528         ! 
    527529         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    … …  
    574576         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    575577         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
     578         CALL tab_1d_2d( nbpb, sfx_sub       , npb, sfx_sub_1d(1:nbpb)   , jpi, jpj )         
    576579         ! 
    577580         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r5487 r6851  
    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 
    … …  
    118117      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
    119118      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 
     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 
    … …  
    653663         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice  
    654664           
     665         ! virtual salt flux to keep salinity constant 
     666         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     667            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 
     668               &                            - sm_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  sm_i  from the ocean  
     669         ENDIF 
     670 
    655671         ! Contribution to mass flux 
    656672         ! All snow is thrown in the ocean, and seawater is taken to replace the volume 
    … …  
    686702      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    687703       
    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 ) 
     704      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
     705      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
    690706      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    691707      CALL wrk_dealloc( jpij, nlay_i, icount ) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r5202 r6851  
    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         !---------------------- 
    … …  
    346332         DO ji = 1, nbpac 
    347333            ztmelts       = - tmut * zs_newice(ji) + rt0                  ! Melting point (K) 
    348             ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                             & 
     334            ze_newice(ji) =   rhoic * (  cpic * ( ztmelts - t_bo_1d(ji) )                                         & 
    349335               &                       + lfus * ( 1.0 - ( ztmelts - rt0 ) / MIN( t_bo_1d(ji) - rt0, -epsi10 ) )   & 
    350336               &                       - rcp  *         ( ztmelts - rt0 )  ) 
    … …  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r5123 r6851  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r5836 r6851  
    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) * e1e2t(:,:)  ! Age content 
    171177            z0es (:,:,jl)   = e_s  (:,:,1,jl) * e1e2t(:,:)  ! Snow heat content 
    172             DO jk = 1, nlay_i 
     178           DO jk = 1, nlay_i 
    173179               z0ei  (:,:,jk,jl) = e_i  (:,:,jk,jl) * e1e2t(:,:) ! 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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90

    r5836 r6851  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

    r5836 r6851  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r5202 r6851  
    163163               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    164164               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
     165            END DO 
     166         END DO 
     167      END DO 
     168      ! Force the upper limit of ht_i to always be < hi_max (99 m). 
     169      DO jj = 1, jpj 
     170         DO ji = 1, jpi 
     171            rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 
     172            ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 
     173            a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 
     174         END DO 
     175      END DO 
     176 
     177      DO jl = 1, jpl 
     178         DO jj = 1, jpj 
     179            DO ji = 1, jpi 
     180               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    165181               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    166182               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    … …  
    168184         END DO 
    169185      END DO 
    170  
     186       
    171187      IF(  nn_icesal == 2  )THEN 
    172188         DO jl = 1, jpl 
    … …  
    298314      ! Vertically constant, constant in time 
    299315      !--------------------------------------- 
    300       IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
     316      IF(  nn_icesal == 1  )  THEN 
     317         s_i (:,:,:,:) = rn_icesal 
     318         sm_i(:,:,:)   = rn_icesal 
     319      ENDIF 
    301320 
    302321      !----------------------------------- 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r6140 r6851  
    154154      ENDIF 
    155155 
    156       IF ( iom_use( "icecolf" ) ) THEN  
    157          DO jj = 1, jpj 
    158             DO ji = 1, jpi 
    159                rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 
    160                z2d(ji,jj) = hicol(ji,jj) * rswitch 
    161             END DO 
    162          END DO 
    163          CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
    164       ENDIF 
    165  
     156      IF ( iom_use( "icecolf" ) )   CALL iom_put( "icecolf", hicol )  ! frazil ice collection thickness 
     157  
    166158      CALL iom_put( "isst"        , sst_m               )        ! sea surface temperature 
    167159      CALL iom_put( "isss"        , sss_m               )        ! sea surface salinity 
    … …  
    187179      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    188180 
    189       CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from brines 
    190       CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from brines 
    191       CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from brines 
    192       CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from brines 
    193       CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from brines 
     181      CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from bottom growth 
     182      CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from bottom melt 
     183      CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from surface melt 
     184      CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from snow ice formation 
     185      CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from open water formation 
    194186      CALL iom_put( "sfxdyn"      , sfx_dyn * rday      )        ! salt flux from ridging rafting 
    195       CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from limupdate (resultant) 
     187      CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from residual 
    196188      CALL iom_put( "sfxbri"      , sfx_bri * rday      )        ! salt flux from brines 
     189      CALL iom_put( "sfxsub"      , sfx_sub * rday      )        ! salt flux from sublimation 
    197190      CALL iom_put( "sfx"         , sfx     * rday      )        ! total salt flux 
    198191 
    … …  
    233226      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
    234227       
     228      IF ( iom_use( "vfxthin" ) ) THEN   ! ice production for open water + thin ice (<20cm) => comparable to observations   
     229         DO jj = 1, jpj  
     230            DO ji = 1, jpi 
     231               z2d(ji,jj)  = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi06 ) * zswi(ji,jj) ! mean ice thickness 
     232            END DO 
     233         END DO 
     234         WHERE( z2d(:,:) < 0.2 .AND. z2d(:,:) > 0. ) ; z2da = wfx_bog 
     235         ELSEWHERE                                   ; z2da = 0._wp 
     236         END WHERE 
     237         CALL iom_put( "vfxthin", ( wfx_opw + z2da ) * ztmp ) 
     238      ENDIF 
     239 
    235240      !-------------------------------- 
    236241      ! Output values for each category 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r5407 r6851  
    4545   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d   
    4646   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d      
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    4748 
    4849   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d 
    … …  
    8384   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d   
    8485 
     86   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d 
     87 
    8588   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip 
    8689   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   frld_1d       !: <==> the 2D  frld 
    … …  
    9194   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
    9295   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
     96   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qevap_ice_1d  !: <==> the 3D  qevap_ice 
    9397   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    9498   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    107111   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m] 
    108112   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m] 
     113   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m] 
    109114   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m] 
    110115   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice] 
    … …  
    144149         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,    &  
    145150         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) ,                      & 
     151         &      rn_amax_1d(jpij) ,                                         & 
    146152         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      & 
    147153         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) ,   & 
    … …  
    153159         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    154160         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
    155          &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
     161         &      qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0         (jpij) ,                     &   
    156162         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    157          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
     163         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  & 
    158164         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    159165         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    … …  
    161167      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
    162168         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    163          &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
    164          &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
    165          &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
    166          &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 
     169         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) ,    &     
     170         &      dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     171         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,           &             
     172         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                               & 
    167173         &      qh_i_old(jpij,0:nlay_i+1), h_i_old(jpij,0:nlay_i+1) , STAT=ierr(3)) 
    168174      ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r5656 r6851  
    390390      !!  ** Method  : time coefficient and call to atomic routines 
    391391      !!----------------------------------------------------------------------- 
    392       INTEGER :: ji,jj,jn 
    393       REAL(wp) :: zalpha 
    394       REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr  
     392      INTEGER  ::   ji, jj, jn 
     393      REAL(wp) ::   zalpha 
     394      REAL(wp), DIMENSION(jpi,jpj,7) ::   tabice_agr  
    395395      !!-----------------------------------------------------------------------       
    396396      ! 
    … …  
    399399      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 
    400400      ! 
    401       tabice_agr(:,:,:) = 0.e0 
    402       DO jn =1,7 
    403          DO jj =1,2 
     401      tabice_agr(:,:,:) = 0._wp 
     402      DO jn = 1, 7 
     403         DO jj = 1, 2 
    404404            DO ji = 1, jpi 
    405405               tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
    … …  
    409409      END DO 
    410410 
    411       DO jn =1,7 
     411      DO jn = 1, 7 
    412412         DO jj = 1, jpj 
    413             DO ji=1,2 
     413            DO ji = 1, 2 
    414414               tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
    415415               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)  
    … …  
    529529            END DO 
    530530         END DO 
     531      ELSE 
     532         DO jj=MAX(j1,2),j2 
     533            DO ji=MAX(i1,2),i2 
     534               uice_agr(ji,jj) = tabres(ji,jj) 
     535            END DO 
     536         END DO 
    531537      ENDIF 
    532538#else 
    … …  
    541547            END DO 
    542548         END DO 
     549      ELSE 
     550         DO jj= j1, j2 
     551            DO ji= i1, i2 
     552               uice_agr(ji,jj) = tabres(ji,jj) 
     553            END DO 
     554         END DO 
    543555      ENDIF 
    544556#endif 
    … …  
    566578                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    567579               ENDIF 
     580            END DO 
     581         END DO 
     582      ELSE 
     583         DO jj=MAX(j1,2),j2 
     584            DO ji=MAX(i1,2),i2 
     585               vice_agr(ji,jj) = tabres(ji,jj) 
    568586            END DO 
    569587         END DO 
    … …  
    580598            END DO 
    581599         END DO 
     600      ELSE 
     601         DO jj= j1 ,j2 
     602            DO ji = i1, i2 
     603               vice_agr(ji,jj) = tabres(ji,jj) 
     604            END DO 
     605         END DO 
    582606      ENDIF 
    583607#endif 
    … …  
    585609 
    586610 
    587    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 
     611   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) 
    588612      !!----------------------------------------------------------------------- 
    589613      !!                    *** ROUTINE interp_adv_ice ***                            
    … …  
    593617      !!              put -9999 where no ice for correct extrapolation              
    594618      !!----------------------------------------------------------------------- 
    595       INTEGER, INTENT(in) :: i1, i2, j1, j2 
    596       REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
    597       LOGICAL, INTENT(in) :: before 
    598       !! 
     619      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2 
     620      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::  tabres 
     621      LOGICAL                               , INTENT(in   ) ::  before 
     622      ! 
    599623      INTEGER :: ji, jj, jk 
    600624      !!----------------------------------------------------------------------- 
    601625      ! 
    602626      IF( before ) THEN 
    603          DO jj=j1,j2 
    604             DO ji=i1,i2 
    605                IF( tms(ji,jj) == 0. ) THEN 
    606                   tabres(ji,jj,:) = -9999.  
     627         DO jj = j1, j2 
     628            DO ji = i1, i2 
     629               IF( tms(ji,jj) == 0._wp ) THEN 
     630                  tabres(ji,jj,:) = -9999  
    607631               ELSE 
    608632                  tabres(ji,jj, 1) = frld  (ji,jj) 
    … …  
    613637                  tabres(ji,jj, 6) = tbif  (ji,jj,3) 
    614638                  tabres(ji,jj, 7) = qstoif(ji,jj) 
    615                ENDIF 
     639               ENDIF 
    616640            END DO 
     641         END DO 
     642      ELSE 
     643         DO jj = j1, j2 
     644            DO ji = i1, i2 
     645               DO jk = k1, k2 
     646                  tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) 
     647               END DO 
     648            END DO 
    617649         END DO 
    618650      ENDIF 
    … …  
    629661   END SUBROUTINE agrif_lim2_interp_empty 
    630662#endif 
     663   !!====================================================================== 
    631664END MODULE agrif_lim2_interp 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DIA/dia25h.F90

    r6347 r6851  
    2525   LOGICAL, PUBLIC ::   ln_dia25h     !:  25h mean output 
    2626 
    27   !! * variables for calculating 25-hourly means 
    28   REAL(wp) ::   r1_25 = 1._wp / 25.0_wp    ! factor for the mean calulation 
     27   !! * variables for calculating 25-hourly means 
     28   REAL(wp) ::   r1_25 = 1._wp / 25.0_wp    ! factor for the mean calulation 
    2929   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:,:) ::   tn_25h  , sn_25h 
    3030   REAL(wp),SAVE, ALLOCATABLE,   DIMENSION(:,:)   ::   sshn_25h  
    … …  
    5555      !! 
    5656      !!--------------------------------------------------------------------------- 
    57       INTEGER ::   ios                 ! Local integer output status for namelist read 
    58       INTEGER ::   ierror              ! Local integer for memory allocation 
     57      INTEGER ::   ios, ierror   ! Local integer 
    5958      ! 
    6059      NAMELIST/nam_dia25h/ ln_dia25h 
    … …  
    159158      !! 
    160159      !!---------------------------------------------------------------------- 
    161       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    162       ! 
    163       INTEGER ::   ji, jj, jk 
    164       LOGICAL ::   ll_print = .FALSE.    ! =T print and flush numout 
    165       REAL(wp)                         ::   zsto, zout, zmax, zjulian, zmdi   ! temporary reals 
    166       INTEGER                          ::   i_steps                           ! no of timesteps per hour 
     160      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     161      ! 
     162      INTEGER  ::   ji, jj, jk               ! dummy loop indices 
     163      INTEGER  ::   i_steps                  ! no of timesteps per hour 
     164      INTEGER  ::   iyear0, nimonth0,iday0   ! start year,imonth,day 
     165      LOGICAL  ::   ll_print = .FALSE.       ! =T print and flush numout 
     166      REAL(wp) ::   zsto, zout, zmax, zjulian, zmdi   ! temporary reals 
    167167      REAL(wp), DIMENSION(jpi,jpj    ) ::   zw2d, un_dm, vn_dm                ! temporary workspace 
    168168      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zw3d                              ! temporary workspace 
    169       REAL(wp), DIMENSION(jpi,jpj,3)   ::   zwtmb                             ! temporary workspace 
    170       INTEGER                          ::   iyear0, nimonth0,iday0            ! start year,imonth,day 
     169      REAL(wp), DIMENSION(jpi,jpj, 3 ) ::   zwtmb                             ! temporary workspace 
    171170      !!---------------------------------------------------------------------- 
    172171 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r6140 r6851  
    212212      REAL(wp) ::   zztmp   
    213213      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    214       ! reading initial file 
    215       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    216       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    217       CHARACTER(len=100)            ::   cn_dir 
    218       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    219       INTEGER  ::   ios=0 
    220  
    221       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    222       ! 
    223  
    224       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    225       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    226 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    227       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    228       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    229 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    230       IF(lwm) WRITE ( numond, namtsd ) 
    231214      ! 
    232215      !!---------------------------------------------------------------------- 
    … …  
    250233      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    251234 
    252       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    253       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    254       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     235 
     236      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     237      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     238      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    255239      CALL iom_close( inum ) 
     240 
    256241      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    257242      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DIA/diacfl.F90

    r6347 r6851  
    151151            WRITE(numout,*) 'dia_cfl     : Maximum Courant number information for the run:' 
    152152            WRITE(numout,*) '~~~~~~~~~~~~' 
    153             WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cu', cu_max,   & 
    154                &                                                           'at (i,j,k) = (', cu_loc(1), cu_loc(2), cu_loc(3), ')' 
     153            WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cu', cu_max, 'at (i, j, k) = (', cu_loc(1), cu_loc(2), cu_loc(3), ')' 
    155154            WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cu_max) 
    156             WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cv', cv_max,   & 
    157                &                                                           'at (i,j,k) = (', cv_loc(1), cv_loc(2), cv_loc(3), ')' 
     155            WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cv', cv_max, 'at (i, j, k) = (', cv_loc(1), cv_loc(2), cv_loc(3), ')' 
    158156            WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cv_max) 
    159             WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cw', cw_max,   & 
    160                &                                                           'at (i,j,k) = (', cw_loc(1), cw_loc(2), cw_loc(3), ')' 
     157            WRITE(numout,FMT='(12x,a12,7x,f6.4,5x,a16,i4,1x,i4,1x,i4,a1)') 'Run Max Cw', cw_max, 'at (i, j, k) = (', cw_loc(1), cw_loc(2), cw_loc(3), ')' 
    161158            WRITE(numout,FMT='(12x,a8,11x,f7.1)') ' => dt/C', dt*(1.0/cw_max) 
    162159 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r6140 r6851  
    118118      !! ** Method  :  use iom_put 
    119119      !!---------------------------------------------------------------------- 
    120       !! 
    121       INTEGER, INTENT( in ) ::   kt      ! ocean time-step index 
    122       !! 
    123       INTEGER                      ::   ji, jj, jk              ! dummy loop indices 
    124       INTEGER                      ::   jkbot                   ! 
    125       REAL(wp)                     ::   zztmp, zztmpx, zztmpy   !  
    126       !! 
    127       REAL(wp), POINTER, DIMENSION(:,:)   :: z2d      ! 2D workspace 
    128       REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d      ! 3D workspace 
     120      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
     121      ! 
     122      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     123      INTEGER  ::   jkbot        ! local integer 
     124      REAL(wp) ::   zztmp, zztmpx, zztmpy   ! local scalars 
     125      REAL(wp), POINTER, DIMENSION(:,:)   ::   z2d   ! 2D workspace 
     126      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z3d   ! 3D     - 
    129127      !!---------------------------------------------------------------------- 
    130128      !  
    131129      IF( nn_timing == 1 )   CALL timing_start('dia_wri') 
    132130      !  
    133       CALL wrk_alloc( jpi , jpj      , z2d ) 
    134       CALL wrk_alloc( jpi , jpj, jpk , z3d ) 
     131      CALL wrk_alloc( jpi,jpj,      z2d ) 
     132      CALL wrk_alloc( jpi,jpj,jpk,  z3d ) 
    135133      ! 
    136134      ! Output the initial state and forcings 
    … …  
    140138      ENDIF 
    141139 
    142       IF( ln_linssh ) THEN 
    143          CALL iom_put( "e3t" , e3t_n(:,:,:) ) 
    144          CALL iom_put( "e3u" , e3u_n(:,:,:) ) 
    145          CALL iom_put( "e3v" , e3v_n(:,:,:) ) 
    146          CALL iom_put( "e3w" , e3w_n(:,:,:) ) 
    147       ENDIF 
     140      ! Output of initial vertical scale factor 
     141      CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
     142      CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
     143      CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
     144      ! 
     145      CALL iom_put( "e3t" , e3t_n(:,:,:) ) 
     146      CALL iom_put( "e3u" , e3u_n(:,:,:) ) 
     147      CALL iom_put( "e3v" , e3v_n(:,:,:) ) 
     148      CALL iom_put( "e3w" , e3w_n(:,:,:) ) 
     149      IF( iom_use("e3tdef") )   & 
     150         CALL iom_put( "e3tdef"  , ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    148151 
    149152      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
    150       if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    151153       
    152154      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    184186               z2d(ji,jj) = rau0 * SQRT( zztmpx * zztmpx + zztmpy * zztmpy ) * tmask(ji,jj,1)  
    185187               ! 
    186             ENDDO 
    187          ENDDO 
     188            END DO 
     189         END DO 
    188190         CALL lbc_lnk( z2d, 'T', 1. ) 
    189191         CALL iom_put( "taubot", z2d )            
    … …  
    228230      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
    229231      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
     232 
     233      IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
     234      IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    230235 
    231236      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    275280            DO jj = 2, jpjm1 
    276281               DO ji = fs_2, fs_jpim1   ! vector opt. 
    277                   zztmp   = 1._wp / ( e1e2t(ji,jj) * e3t_n(ji,jj,jk) ) 
    278                   zztmpx  = 0.5 * (  un(ji-1,jj,jk) * un(ji-1,jj,jk) * e2u(ji-1,jj) * e3u_n(ji-1,jj,jk)    & 
    279                      &             + un(ji  ,jj,jk) * un(ji  ,jj,jk) * e2u(ji  ,jj) * e3u_n(ji  ,jj,jk) )  & 
    280                      &          *  zztmp  
    281                   ! 
    282                   zztmpy  = 0.5 * (  vn(ji,jj-1,jk) * vn(ji,jj-1,jk) * e1v(ji,jj-1) * e3v_n(ji,jj-1,jk)    & 
    283                      &             + vn(ji,jj  ,jk) * vn(ji,jj  ,jk) * e1v(ji,jj  ) * e3v_n(ji,jj  ,jk) )  & 
    284                      &          *  zztmp  
    285                   ! 
    286                   rke(ji,jj,jk) = 0.5_wp * ( zztmpx + zztmpy ) 
    287                   ! 
    288                ENDDO 
    289             ENDDO 
    290          ENDDO 
     282                  zztmpx  = un(ji-1,jj,jk) * un(ji-1,jj,jk) * e1e2u(ji-1,jj) * e3u_n(ji-1,jj,jk)   & 
     283                     &    + un(ji  ,jj,jk) * un(ji  ,jj,jk) * e1e2u(ji  ,jj) * e3u_n(ji  ,jj,jk)  
     284                  zztmpy  = vn(ji,jj-1,jk) * vn(ji,jj-1,jk) * e1e2v(ji,jj-1) * e3v_n(ji,jj-1,jk)   & 
     285                     &    + vn(ji,jj  ,jk) * vn(ji,jj  ,jk) * e1e2v(ji,jj  ) * e3v_n(ji,jj  ,jk)                  ! 
     286                  rke(ji,jj,jk) = 0.25_wp * ( zztmpx + zztmpy ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) 
     287               END DO 
     288            END DO 
     289         END DO 
    291290         CALL lbc_lnk( rke, 'T', 1. ) 
    292291         CALL iom_put( "eken", rke )            
    293292      ENDIF 
    294           
     293      ! 
     294      CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
     295      ! 
    295296      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    296          z3d(:,:,jpk) = 0.e0 
     297         z3d(:,:,jpk) = 0._wp 
    297298         DO jk = 1, jpkm1 
    298             z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk) 
     299            z3d(:,:,jk) = rau0 * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) 
    299300         END DO 
    300301         CALL iom_put( "u_masstr", z3d )                  ! mass transport in i-direction 
    … …  
    302303       
    303304      IF( iom_use("u_heattr") ) THEN 
    304          z2d(:,:) = 0.e0  
     305         z2d(:,:) = 0._wp 
    305306         DO jk = 1, jpkm1 
    306307            DO jj = 2, jpjm1 
    … …  
    315316 
    316317      IF( iom_use("u_salttr") ) THEN 
    317          z2d(:,:) = 0.e0  
     318         z2d(:,:) = 0._wp 
    318319         DO jk = 1, jpkm1 
    319320            DO jj = 2, jpjm1 
    … …  
    331332         z3d(:,:,jpk) = 0.e0 
    332333         DO jk = 1, jpkm1 
    333             z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk) 
     334            z3d(:,:,jk) = rau0 * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) 
    334335         END DO 
    335336         CALL iom_put( "v_masstr", z3d )                  ! mass transport in j-direction 
    … …  
    362363      ENDIF 
    363364      ! 
    364       CALL wrk_dealloc( jpi , jpj      , z2d ) 
    365       CALL wrk_dealloc( jpi , jpj, jpk , z3d ) 
    366       ! 
    367       ! If we want tmb values  
    368  
    369       IF (ln_diatmb) THEN 
    370          CALL dia_tmb  
    371       ENDIF  
    372       IF (ln_dia25h) THEN 
    373          CALL dia_25h( kt ) 
    374       ENDIF  
    375  
     365      CALL wrk_dealloc( jpi,jpj    ,   z2d ) 
     366      CALL wrk_dealloc( jpi,jpj,jpk,   z3d ) 
     367      ! 
     368      IF( ln_diatmb )   CALL dia_tmb            ! Top, Middle, Bottom diagnostics 
     369      IF( ln_dia25h )   CALL dia_25h( kt )      ! 25h time-mean diagnostics 
     370      ! 
    376371      IF( nn_timing == 1 )   CALL timing_stop('dia_wri') 
    377372      ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DIU/cool_skin.F90

    r6075 r6851  
    1717   USE in_out_manager 
    1818   USE sbc_oce 
     19   USE lib_mpp 
    1920   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    2021    
    … …  
    5556      !!  
    5657      !!---------------------------------------------------------------------- 
    57        
    58       IMPLICIT NONE 
    59        
    6058      ALLOCATE( x_csdsst(jpi,jpj), x_csthick(jpi,jpj) ) 
    61       x_csdsst = 0. 
    62       x_csthick = 0. 
    63        
     59      x_csdsst  = 0._wp 
     60      x_csthick = 0._wp 
     61      !       
    6462   END SUBROUTINE diurnal_sst_coolskin_init 
    65   
     63 
     64 
    6665   SUBROUTINE diurnal_sst_coolskin_step(psqflux, pstauflux, psrho, rdt) 
    6766      !!---------------------------------------------------------------------- 
    … …  
    7473      !! ** Reference :  
    7574      !!---------------------------------------------------------------------- 
    76       
    77       IMPLICIT NONE 
    78       
    79       ! Dummy variables 
    80       REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psqflux     ! Heat (non-solar)(Watts) 
    81       REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: pstauflux   ! Wind stress (kg/ m s^2) 
    82       REAL(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho       ! Water density (kg/m^3) 
    83       REAL(wp), INTENT(IN) :: rdt                             ! Time-step 
    84       
    85       ! Local variables 
    86       REAL(wp), DIMENSION(jpi,jpj) :: z_fv                    ! Friction velocity      
    87       REAL(wp), DIMENSION(jpi,jpj) :: z_gamma                 ! Dimensionless function of wind speed 
    88       REAL(wp), DIMENSION(jpi,jpj) :: z_lamda                 ! Sauders (dimensionless) proportionality constant 
    89       REAL(wp), DIMENSION(jpi,jpj) :: z_wspd                  ! Wind speed (m/s) 
    90       REAL(wp) :: z_ztx                                       ! Temporary u wind stress 
    91       REAL(wp) :: z_zty                                       ! Temporary v wind stress 
    92       REAL(wp) :: z_zmod                                      ! Temporary total wind stress 
    93       
    94       INTEGER :: ji,jj 
     75      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   psqflux     ! Heat (non-solar)(Watts) 
     76      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   pstauflux   ! Wind stress (kg/ m s^2) 
     77      REAL(wp), DIMENSION(jpi,jpj), INTENT(in) ::   psrho       ! Water density (kg/m^3) 
     78      REAL(wp)                    , INTENT(in) ::   rdt         ! Time-step 
     79      ! 
     80      INTEGER  ::   ji, jj                 ! dummy loop indices 
     81      REAL(wp) ::   z_ztx, z_zty, z_zmod   ! local scalar 
     82      REAL(wp), DIMENSION(jpi,jpj) ::   z_fv      ! Friction velocity      
     83      REAL(wp), DIMENSION(jpi,jpj) ::   z_gamma   ! Dimensionless function of wind speed 
     84      REAL(wp), DIMENSION(jpi,jpj) ::   z_lamda   ! Sauders (dimensionless) proportionality constant 
     85      REAL(wp), DIMENSION(jpi,jpj) ::   z_wspd    ! Wind speed (m/s) 
     86      !!---------------------------------------------------------------------- 
    9587      
    9688      IF ( .NOT. ln_blk_core ) THEN 
    … …  
    10799               z_wspd(ji,jj) = SQRT( pstauflux(ji,jj) / ( pp_cda * pp_rhoa ) ) 
    108100            ELSE 
    109                z_fv(ji,jj) = 0. 
    110                z_wspd(ji,jj) = 0.      
     101               z_fv  (ji,jj) = 0._wp 
     102               z_wspd(ji,jj) = 0._wp 
    111103            ENDIF 
    112  
    113104  
    114105            ! Calculate gamma function which is dependent upon wind speed 
    … …  
    119110            ENDIF 
    120111 
    121  
    122112            ! Calculate lamda function 
    123113            IF( tmask(ji,jj,1) == 1. .AND. z_fv(ji,jj) /= 0 ) THEN 
    … …  
    126116               z_lamda(ji,jj) = 0. 
    127117            ENDIF 
    128  
    129  
    130118 
    131119            ! Calculate the cool skin thickness - only when heat flux is out of the ocean 
    … …  
    136124            ENDIF 
    137125 
    138  
    139  
    140126            ! Calculate the cool skin correction - only when the heat flux is out of the ocean 
    141127            IF( tmask(ji,jj,1) == 1. .AND. x_csthick(ji,jj) /= 0. .AND. psqflux(ji,jj) < 0. ) THEN 
    … …  
    144130               x_csdsst(ji,jj) = 0. 
    145131            ENDIF 
    146  
    147          ENDDO 
    148       ENDDO 
    149  
     132            ! 
     133         END DO 
     134      END DO 
     135      ! 
    150136   END SUBROUTINE diurnal_sst_coolskin_step 
    151137 
    152  
     138   !!===================================================================== 
    153139END MODULE cool_skin 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

    r6152 r6851  
    653653         ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) 
    654654      END DO 
    655  
    656       ! Write outputs 
    657       ! ============= 
    658       CALL iom_put(     "e3t",   e3t_n(:,:,:) ) 
    659       CALL iom_put(     "e3u",   e3u_n(:,:,:) ) 
    660       CALL iom_put(     "e3v",   e3v_n(:,:,:) ) 
    661       CALL iom_put(     "e3w",   e3w_n(:,:,:) ) 
    662       CALL iom_put( "tpt_dep", gde3w_n(:,:,:) ) 
    663       IF( iom_use("e3tdef") )   & 
    664          CALL iom_put( "e3tdef", ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100. * tmask(:,:,:) ) ** 2 ) 
    665655 
    666656      ! write restart file 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r5836 r6851  
    7171      ! 
    7272      !                                                         ! horizontal mesh (inum3) 
    73       CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude 
    74       CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r4 ) 
    75       CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r4 ) 
    76       CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r4 ) 
    77        
    78       CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude 
    79       CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r4 ) 
    80       CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r4 ) 
    81       CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r4 ) 
     73      CALL iom_rstput( 0, 0, inum0, 'glamt', glamt, ktype = jp_r8 )     !    ! latitude 
     74      CALL iom_rstput( 0, 0, inum0, 'glamu', glamu, ktype = jp_r8 ) 
     75      CALL iom_rstput( 0, 0, inum0, 'glamv', glamv, ktype = jp_r8 ) 
     76      CALL iom_rstput( 0, 0, inum0, 'glamf', glamf, ktype = jp_r8 ) 
     77       
     78      CALL iom_rstput( 0, 0, inum0, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude 
     79      CALL iom_rstput( 0, 0, inum0, 'gphiu', gphiu, ktype = jp_r8 ) 
     80      CALL iom_rstput( 0, 0, inum0, 'gphiv', gphiv, ktype = jp_r8 ) 
     81      CALL iom_rstput( 0, 0, inum0, 'gphif', gphif, ktype = jp_r8 ) 
    8282       
    8383      CALL iom_rstput( 0, 0, inum0, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors 
    … …  
    129129      !!                                   masks, depth and vertical scale factors 
    130130      !!---------------------------------------------------------------------- 
    131       !! 
    132131      INTEGER           ::   inum0    ! temprary units for 'mesh_mask.nc' file 
    133132      INTEGER           ::   inum1    ! temprary units for 'mesh.nc'      file 
    … …  
    229228 
    230229      !                                                         ! horizontal mesh (inum3) 
    231       CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r4 )     !    ! latitude 
    232       CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r4 ) 
    233       CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r4 ) 
    234       CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r4 ) 
    235        
    236       CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r4 )     !    ! longitude 
    237       CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r4 ) 
    238       CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r4 ) 
    239       CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r4 ) 
     230      CALL iom_rstput( 0, 0, inum3, 'glamt', glamt, ktype = jp_r8 )     !    ! latitude 
     231      CALL iom_rstput( 0, 0, inum3, 'glamu', glamu, ktype = jp_r8 ) 
     232      CALL iom_rstput( 0, 0, inum3, 'glamv', glamv, ktype = jp_r8 ) 
     233      CALL iom_rstput( 0, 0, inum3, 'glamf', glamf, ktype = jp_r8 ) 
     234       
     235      CALL iom_rstput( 0, 0, inum3, 'gphit', gphit, ktype = jp_r8 )     !    ! longitude 
     236      CALL iom_rstput( 0, 0, inum3, 'gphiu', gphiu, ktype = jp_r8 ) 
     237      CALL iom_rstput( 0, 0, inum3, 'gphiv', gphiv, ktype = jp_r8 ) 
     238      CALL iom_rstput( 0, 0, inum3, 'gphif', gphif, ktype = jp_r8 ) 
    240239       
    241240      CALL iom_rstput( 0, 0, inum3, 'e1t', e1t, ktype = jp_r8 )         !    ! e1 scale factors 
    … …  
    257256      CALL iom_rstput( 0, 0, inum4, 'misf', zprt, ktype = jp_i2 )       !    ! nb of ocean T-points 
    258257      zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp ) 
    259       CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r4 )       !    ! nb of ocean T-points 
     258      CALL iom_rstput( 0, 0, inum4, 'isfdraft', zprt, ktype = jp_r8 )       !    ! nb of ocean T-points 
    260259             
    261260      IF( ln_sco ) THEN                                         ! s-coordinate 
    … …  
    279278         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    280279         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
    281          CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
    282          CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 
     280         CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 )      
     281         CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 
    283282      ENDIF 
    284283       
    … …  
    302301         ! 
    303302         IF( nmsh <= 3 ) THEN                                   !    ! 3D depth 
    304             CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
     303            CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r8 )      
    305304            DO jk = 1,jpk    
    306305               DO jj = 1, jpjm1    
    … …  
    312311            END DO 
    313312            CALL lbc_lnk( zdepu, 'U', 1. )   ;   CALL lbc_lnk( zdepv, 'V', 1. )  
    314             CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r4 ) 
    315             CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r4 ) 
    316             CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 ) 
     313            CALL iom_rstput( 0, 0, inum4, 'gdepu', zdepu, ktype = jp_r8 ) 
     314            CALL iom_rstput( 0, 0, inum4, 'gdepv', zdepv, ktype = jp_r8 ) 
     315            CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r8 ) 
    317316         ELSE                                                   !    ! 2D bottom depth 
    318317            DO jj = 1,jpj    
    … …  
    322321               END DO 
    323322            END DO 
    324             CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r4 )      
    325             CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r4 )  
     323            CALL iom_rstput( 0, 0, inum4, 'hdept', zprt, ktype = jp_r8 )      
     324            CALL iom_rstput( 0, 0, inum4, 'hdepw', zprw, ktype = jp_r8 )  
    326325         ENDIF 
    327326         ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r6152 r6851  
    137137      IF( ln_sco      )   ioptio = ioptio + 1 
    138138      IF( ioptio /= 1 )   CALL ctl_stop( ' none or several vertical coordinate options used' ) 
     139      ! 
     140      ioptio = 0 
     141      IF ( ln_zco .AND. ln_isfcav )   ioptio = ioptio + 1 
     142      IF ( ln_sco .AND. ln_isfcav )   ioptio = ioptio + 1 
     143      IF( ioptio > 0 )   CALL ctl_stop( ' Cavity not tested/compatible with full step (zco) and sigma (ln_sco) ' ) 
    139144      ! 
    140145      ! Build the vertical coordinate system 
    … …  
    503508            CALL iom_close( inum ) 
    504509            mbathy(:,:) = INT( bathy(:,:) ) 
     510            ! initialisation isf variables 
     511            risfdep(:,:) = 0._wp   ;   misfdep(:,:) = 1              
    505512            !                                                ! ===================== 
    506513            IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) THEN    ! ORCA R2 configuration 
    … …  
    539546            CALL iom_close( inum ) 
    540547            !                                                 
    541             risfdep(:,:)=0._wp          
    542             misfdep(:,:)=1              
     548            ! initialisation isf variables 
     549            risfdep(:,:) = 0._wp   ;   misfdep(:,:) = 1              
     550            ! 
    543551            IF ( ln_isfcav ) THEN 
    544552               CALL iom_open ( 'isf_draft_meter.nc', inum )  

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_cen2.F90

    r6140 r6851  
    118118      ENDIF 
    119119      DO jk = 2, jpkm1                    ! interior advective fluxes 
    120          DO jj = 2, jpjm1                       ! 1/4 * Vertical transport 
    121             DO ji = fs_2, fs_jpim1 
     120         DO jj = 2, jpj                         ! 1/4 * Vertical transport 
     121            DO ji = fs_2, jpi 
    122122               zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 
    123123            END DO 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DYN/dynadv_ubs.F90

    r6140 r6851  
    211211      ENDIF 
    212212      DO jk = 2, jpkm1                          ! interior fluxes 
    213          DO jj = 2, jpjm1 
    214             DO ji = fs_2, fs_jpim1 
     213         DO jj = 2, jpj 
     214            DO ji = fs_2, jpi 
    215215               zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) 
    216216            END DO 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r6140 r6851  
    294294            ze3va =  ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1)  
    295295            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    296                &                                      / ( ze3va * rau0 )  
     296               &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1)  
    297297         END DO 
    298298      END DO 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    r5215 r6851  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r6347 r6851  
    114114      CASE (30)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "D360") 
    115115      END SELECT 
    116       WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
     116      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' ',i2.2,':',i2.2,':00')") nyear,nmonth,nday,nhour,nminute 
    117117      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    118118 
    … …  
    792792                  ENDIF 
    793793                  IF( PRESENT(pv_r3d) ) THEN 
    794                      IF( idom == jpdom_data ) THEN                         ;   icnt(3) = jpkdta 
     794                     IF( idom == jpdom_data ) THEN                         ;   icnt  (3) = jpkdta 
    795795                     ELSE IF( ll_depth_spec .AND. PRESENT(kstart) ) THEN   ;   istart(3) = kstart(3)   ;   icnt(3) = kcount(3) 
    796                      ELSE                                                  ;   icnt(3) = jpk 
     796                     ELSE                                                  ;   icnt  (3) = jpk 
    797797                     ENDIF 
    798798                  ENDIF 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

    r6140 r6851  
    99   !!            3.5  ! 2012     (S.Mocavero, I. Epicoco) optimization of BDY comm. via lbc_bdy_lnk and lbc_obc_lnk 
    1010   !!            3.4  ! 2012-12  (R. Bourdalle-Badie, G. Reffray)  add a C1D case   
     11   !!            3.6  ! 2015-06  (O. Tintó and M. Castrillo)  add lbc_lnk_multi   
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_mpp_mpi 
    … …  
    2223 
    2324   INTERFACE lbc_lnk_multi 
    24       MODULE PROCEDURE mpp_lnk_2d_9 
     25      MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 
    2526   END INTERFACE 
    2627   ! 
    … …  
    2930   END INTERFACE 
    3031   ! 
    31 !JMM interface not defined if not key_mpp_mpi : likely do not compile without this CPP key !!!! 
    3232   INTERFACE lbc_sum 
    3333      MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    3434   END INTERFACE 
    35  
     35   ! 
    3636   INTERFACE lbc_bdy_lnk 
    3737      MODULE PROCEDURE mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    … …  
    8383   ! 
    8484   INTERFACE lbc_sum 
    85       MODULE PROCEDURE mpp_lnk_sum_3d, mpp_lnk_sum_2d 
     85      MODULE PROCEDURE lbc_lnk_sum_3d, lbc_lnk_sum_2d 
    8686   END INTERFACE 
    8787 
    … …  
    9090   END INTERFACE 
    9191   ! 
     92   INTERFACE lbc_lnk_multi 
     93      MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 
     94   END INTERFACE 
     95 
    9296   INTERFACE lbc_bdy_lnk 
    9397      MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d 
    … …  
    97101      MODULE PROCEDURE lbc_lnk_2d_e 
    98102   END INTERFACE 
     103    
     104   TYPE arrayptr 
     105      REAL , DIMENSION (:,:),  POINTER :: pt2d 
     106   END TYPE arrayptr 
     107   PUBLIC   arrayptr 
    99108 
    100109   PUBLIC   lbc_lnk       ! ocean/ice  lateral boundary conditions 
     110   PUBLIC   lbc_sum       ! ocean/ice  lateral boundary conditions (sum of the overlap region) 
    101111   PUBLIC   lbc_lnk_e     ! 
     112   PUBLIC   lbc_lnk_multi ! modified ocean lateral boundary conditions 
    102113   PUBLIC   lbc_bdy_lnk   ! ocean lateral BDY boundary conditions 
    103114   PUBLIC   lbc_lnk_icb   ! 
    … …  
    181192      ! 
    182193   END SUBROUTINE lbc_lnk_2d 
     194    
     195    
     196   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     197      !! 
     198      INTEGER :: num_fields 
     199      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     200      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     201      !                                                               ! = T , U , V , F , W and I points 
     202      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     203      !                                                               ! =  1. , the sign is kept 
     204      ! 
     205      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     206      ! 
     207      DO ii = 1, num_fields 
     208        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     209      END DO      
     210      ! 
     211   END SUBROUTINE lbc_lnk_2d_multiple 
     212 
     213   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     214      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     215      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     216      !!--------------------------------------------------------------------- 
     217      ! Second 2D array on which the boundary condition is applied 
     218      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     219      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     220      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     221      ! define the nature of ptab array grid-points 
     222      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     223      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     224      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     225      ! =-1 the sign change across the north fold boundary 
     226      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     227      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     228      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     229      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     230      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     231      !! 
     232      !!--------------------------------------------------------------------- 
     233 
     234      !!The first array 
     235      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     236 
     237      !! Look if more arrays to process 
     238      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     239      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     240      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     241      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     242      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     243      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     244      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     245      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     246 
     247   END SUBROUTINE lbc_lnk_2d_9 
     248 
     249 
     250 
     251 
    183252 
    184253#else 
    … …  
    379448      !     
    380449   END SUBROUTINE lbc_lnk_2d 
     450    
     451    
     452   SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 
     453      !! 
     454      INTEGER :: num_fields 
     455      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     456      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   type_array   ! define the nature of ptab array grid-points 
     457      !                                                               ! = T , U , V , F , W and I points 
     458      REAL(wp)        , DIMENSION(:), INTENT(in   ) ::   psgn_array   ! =-1 the sign change across the north fold boundary 
     459      !                                                               ! =  1. , the sign is kept 
     460      ! 
     461      INTEGER  ::   ii    !!MULTI SEND DUMMY LOOP INDICES 
     462      ! 
     463      DO ii = 1, num_fields 
     464        CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 
     465      END DO      
     466      ! 
     467   END SUBROUTINE lbc_lnk_2d_multiple 
     468 
     469   SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC   & 
     470      &                   , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF   & 
     471      &                   , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 
     472      !!--------------------------------------------------------------------- 
     473      ! Second 2D array on which the boundary condition is applied 
     474      REAL(wp), DIMENSION(jpi,jpj), TARGET          , INTENT(inout) ::   pt2dA 
     475      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dB , pt2dC , pt2dD , pt2dE 
     476      REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) ::   pt2dF , pt2dG , pt2dH , pt2dI 
     477      ! define the nature of ptab array grid-points 
     478      CHARACTER(len=1)                              , INTENT(in   ) ::   cd_typeA 
     479      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeB , cd_typeC , cd_typeD , cd_typeE 
     480      CHARACTER(len=1)                    , OPTIONAL, INTENT(in   ) ::   cd_typeF , cd_typeG , cd_typeH , cd_typeI 
     481      ! =-1 the sign change across the north fold boundary 
     482      REAL(wp)                                      , INTENT(in   ) ::   psgnA 
     483      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnB , psgnC , psgnD , psgnE 
     484      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   psgnF , psgnG , psgnH , psgnI 
     485      CHARACTER(len=3)                    , OPTIONAL, INTENT(in   ) ::   cd_mpp   ! fill the overlap area only 
     486      REAL(wp)                            , OPTIONAL, INTENT(in   ) ::   pval     ! background value (used at closed boundaries) 
     487      !! 
     488      !!--------------------------------------------------------------------- 
     489 
     490      !!The first array 
     491      CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     492 
     493      !! Look if more arrays to process 
     494      IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA )  
     495      IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC )  
     496      IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD )  
     497      IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE )  
     498      IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF )  
     499      IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG )  
     500      IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH )  
     501      IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI )  
     502 
     503   END SUBROUTINE lbc_lnk_2d_9 
     504 
     505   SUBROUTINE lbc_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
     506      !!--------------------------------------------------------------------- 
     507      !!                 ***  ROUTINE lbc_lnk_sum_2d  *** 
     508      !! 
     509      !! ** Purpose :   set lateral boundary conditions on a 2D array (non mpp case) 
     510      !! 
     511      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
     512      !!                coupling if conservation option activated. As no ice shelf are present along 
     513      !!                this line, nothing is done along the north fold. 
     514      !!---------------------------------------------------------------------- 
     515      CHARACTER(len=1)            , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     516      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout)           ::   pt2d      ! 2D array on which the lbc is applied 
     517      REAL(wp)                    , INTENT(in   )           ::   psgn      ! control of the sign  
     518      CHARACTER(len=3)            , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     519      REAL(wp)                    , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     520      !! 
     521      REAL(wp) ::   zland 
     522      !!---------------------------------------------------------------------- 
     523 
     524      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
     525      ELSE                         ;   zland = 0._wp 
     526      ENDIF 
     527 
     528      IF (PRESENT(cd_mpp)) THEN 
     529         ! only fill the overlap area and extra allows  
     530         ! this is in mpp case. In this module, just do nothing 
     531      ELSE 
     532         !                                     ! East-West boundaries 
     533         !                                     ! ==================== 
     534         SELECT CASE ( nperio ) 
     535         ! 
     536         CASE ( 1 , 4 , 6 )                       !** cyclic east-west 
     537            pt2d(jpim1,:) = pt2d(jpim1,:) + pt2d( 1 ,:) 
     538            pt2d(  2  ,:) = pt2d(  2  ,:) + pt2d(jpi,:) 
     539            pt2d( 1 ,:) = 0.0_wp               ! all points 
     540            pt2d(jpi,:) = 0.0_wp 
     541            ! 
     542         CASE DEFAULT                             !** East closed  --  West closed 
     543            SELECT CASE ( cd_type ) 
     544            CASE ( 'T' , 'U' , 'V' , 'W' )            ! T-, U-, V-, W-points 
     545               pt2d( 1 ,:) = zland 
     546               pt2d(jpi,:) = zland 
     547            CASE ( 'F' )                              ! F-point 
     548               pt2d(jpi,:) = zland 
     549            END SELECT 
     550            ! 
     551         END SELECT 
     552         !                                     ! North-South boundaries 
     553         !                                     ! ====================== 
     554         ! Nothing to do for the north fold, there is no ice shelf along this line. 
     555         ! 
     556      END IF 
     557 
     558   END SUBROUTINE 
     559 
     560   SUBROUTINE lbc_lnk_sum_3d( pt3d, cd_type, psgn, cd_mpp, pval ) 
     561      !!--------------------------------------------------------------------- 
     562      !!                 ***  ROUTINE lbc_lnk_sum_3d  *** 
     563      !! 
     564      !! ** Purpose :   set lateral boundary conditions on a 3D array (non mpp case) 
     565      !! 
     566      !! ** Comments:   compute the sum of the common cell (overlap region) for the ice sheet/ocean  
     567      !!                coupling if conservation option activated. As no ice shelf are present along 
     568      !!                this line, nothing is done along the north fold. 
     569      !!---------------------------------------------------------------------- 
     570      CHARACTER(len=1)                , INTENT(in   )           ::   cd_type   ! nature of pt3d grid-points 
     571      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout)           ::   pt3d      ! 3D array on which the lbc is applied 
     572      REAL(wp)                        , INTENT(in   )           ::   psgn      ! control of the sign  
     573      CHARACTER(len=3)                , INTENT(in   ), OPTIONAL ::   cd_mpp    ! MPP only (here do nothing) 
     574      REAL(wp)                        , INTENT(in   ), OPTIONAL ::   pval      ! background value (for closed boundaries) 
     575      !! 
     576      REAL(wp) ::   zland 
     577      !!---------------------------------------------------------------------- 
     578 
     579      IF( PRESENT( pval ) ) THEN   ;   zland = pval      ! set land value (zero by default) 
     580      ELSE                         ;   zland = 0._wp 
     581      ENDIF 
     582 
     583 
     584      IF( PRESENT( cd_mpp ) ) THEN 
     585         ! only fill the overlap area and extra allows  
     586         ! this is in mpp case. In this module, just do nothing 
     587      ELSE 
     588         !                                     !  East-West boundaries 
     589         !                                     ! ====================== 
     590         SELECT CASE ( nperio ) 
     591         ! 
     592         CASE ( 1 , 4 , 6 )                       !**  cyclic east-west 
     593            pt3d(jpim1,:,:) = pt3d(jpim1,:,:) + pt3d( 1 ,:,:) 
     594            pt3d(  2  ,:,:) = pt3d(  2  ,:,:) + pt3d(jpi,:,:)  
     595            pt3d( 1 ,:,:) = 0.0_wp            ! all points 
     596            pt3d(jpi,:,:) = 0.0_wp 
     597            ! 
     598         CASE DEFAULT                             !**  East closed  --  West closed 
     599            SELECT CASE ( cd_type ) 
     600            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
     601               pt3d( 1 ,:,:) = zland 
     602               pt3d(jpi,:,:) = zland 
     603            CASE ( 'F' )                               ! F-point 
     604               pt3d(jpi,:,:) = zland 
     605            END SELECT 
     606            ! 
     607         END SELECT 
     608         !                                     ! North-South boundaries 
     609         !                                     ! ====================== 
     610         ! Nothing to do for the north fold, there is no ice shelf along this line. 
     611         ! 
     612      END IF 
     613   END SUBROUTINE 
     614 
    381615 
    382616#endif 
    … …  
    448682   !!====================================================================== 
    449683END MODULE lbclnk 
     684 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6140 r6851  
    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   mpp_lnk_sum_3d, mpp_lnk_sum_2d 
    7578   PUBLIC   mppscatter, mppgather 
    … …  
    7982   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    8083   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     84   PUBLIC   mpprank 
    8185 
    8286   TYPE arrayptr 
    8387      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8488   END TYPE arrayptr 
     89   PUBLIC   arrayptr 
    8590    
    8691   !! * Interfaces 
    … …  
    106111   INTERFACE mpp_maxloc 
    107112      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     113   END INTERFACE 
     114 
     115   INTERFACE mpp_max_multiple 
     116      MODULE PROCEDURE mppmax_real_multiple 
    108117   END INTERFACE 
    109118 
    … …  
    726735      ! ----------------------- 
    727736      ! 
    728       DO ii = 1 , num_fields 
    729737         !First Array 
    730          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    731             ! 
    732             SELECT CASE ( jpni ) 
    733             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    734             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    735             END SELECT 
    736             ! 
    737          ENDIF 
    738          ! 
    739       END DO 
     738      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     739         ! 
     740         SELECT CASE ( jpni ) 
     741         CASE ( 1 )     ;    
     742             DO ii = 1 , num_fields   
     743                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     744             END DO 
     745         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     746         END SELECT 
     747         ! 
     748      ENDIF 
     749        ! 
    740750      ! 
    741751      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
    … …  
    20202030 
    20212031 
     2032   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     2033      !!---------------------------------------------------------------------- 
     2034      !!                  ***  routine mppmax_real  *** 
     2035      !! 
     2036      !! ** Purpose :   Maximum 
     2037      !! 
     2038      !!---------------------------------------------------------------------- 
     2039      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     2040      INTEGER , INTENT(in   )           ::   NUM 
     2041      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     2042      !! 
     2043      INTEGER  ::   ierror, localcomm 
     2044      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     2045      !!---------------------------------------------------------------------- 
     2046      ! 
     2047      CALL wrk_alloc(NUM , zwork) 
     2048      localcomm = mpi_comm_opa 
     2049      IF( PRESENT(kcom) )   localcomm = kcom 
     2050      ! 
     2051      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     2052      ptab = zwork 
     2053      CALL wrk_dealloc(NUM , zwork) 
     2054      ! 
     2055   END SUBROUTINE mppmax_real_multiple 
     2056 
     2057 
    20222058   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    20232059      !!---------------------------------------------------------------------- 
    … …  
    29132949 
    29142950 
     2951   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2952      !!--------------------------------------------------------------------- 
     2953      !!                   ***  routine mpp_lbc_north_2d  *** 
     2954      !! 
     2955      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2956      !!              in mpp configuration in case of jpn1 > 1 
     2957      !!              (for multiple 2d arrays ) 
     2958      !! 
     2959      !! ** Method  :   North fold condition and mpp with more than one proc 
     2960      !!              in i-direction require a specific treatment. We gather 
     2961      !!              the 4 northern lines of the global domain on 1 processor 
     2962      !!              and apply lbc north-fold on this sub array. Then we 
     2963      !!              scatter the north fold array back to the processors. 
     2964      !! 
     2965      !!---------------------------------------------------------------------- 
     2966      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2967      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2968      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2969      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2970      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2971      !!                                                             ! =  1. , the sign is kept 
     2972      INTEGER ::   ji, jj, jr, jk 
     2973      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2974      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2975      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2976      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2977      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2978      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2979      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2980      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2981      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2982      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2983      INTEGER :: istatus(mpi_status_size) 
     2984      INTEGER :: iflag 
     2985      !!---------------------------------------------------------------------- 
     2986      ! 
     2987      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2988      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2989      ! 
     2990      ijpj   = 4 
     2991      ijpjm1 = 3 
     2992      ! 
     2993       
     2994      DO jk = 1, num_fields 
     2995         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2996            ij = jj - nlcj + ijpj 
     2997            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2998         END DO 
     2999      END DO 
     3000      !                                     ! Build in procs of ncomm_north the znorthgloio 
     3001      itaille = jpi * ijpj 
     3002                                                                   
     3003      IF ( l_north_nogather ) THEN 
     3004         ! 
     3005         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     3006         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     3007         ! 
     3008         ztabr(:,:,:) = 0 
     3009         ztabl(:,:,:) = 0 
     3010 
     3011         DO jk = 1, num_fields 
     3012            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     3013               ij = jj - nlcj + ijpj 
     3014               DO ji = nfsloop, nfeloop 
     3015                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     3016               END DO 
     3017            END DO 
     3018         END DO 
     3019 
     3020         DO jr = 1,nsndto 
     3021            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3022               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     3023            ENDIF 
     3024         END DO 
     3025         DO jr = 1,nsndto 
     3026            iproc = nfipproc(isendto(jr),jpnj) 
     3027            IF(iproc .ne. -1) THEN 
     3028               ilei = nleit (iproc+1) 
     3029               ildi = nldit (iproc+1) 
     3030               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     3031            ENDIF 
     3032            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     3033              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     3034              DO jk = 1 , num_fields 
     3035                 DO jj = 1, ijpj 
     3036                    DO ji = ildi, ilei 
     3037                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     3038                    END DO 
     3039                 END DO 
     3040              END DO 
     3041            ELSE IF (iproc .eq. (narea-1)) THEN 
     3042              DO jk = 1, num_fields 
     3043                 DO jj = 1, ijpj 
     3044                    DO ji = ildi, ilei 
     3045                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     3046                    END DO 
     3047                 END DO 
     3048              END DO 
     3049            ENDIF 
     3050         END DO 
     3051         IF (l_isend) THEN 
     3052            DO jr = 1,nsndto 
     3053               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     3054                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     3055               ENDIF 
     3056            END DO 
     3057         ENDIF 
     3058         ! 
     3059         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     3060            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     3061         END DO 
     3062         ! 
     3063         DO jk = 1, num_fields 
     3064            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3065               ij = jj - nlcj + ijpj 
     3066               DO ji = 1, nlci 
     3067                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     3068               END DO 
     3069            END DO 
     3070         END DO 
     3071          
     3072         ! 
     3073      ELSE 
     3074         ! 
     3075         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     3076            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     3077         ! 
     3078         ztab(:,:,:) = 0.e0 
     3079         DO jk = 1, num_fields 
     3080            DO jr = 1, ndim_rank_north            ! recover the global north array 
     3081               iproc = nrank_north(jr) + 1 
     3082               ildi = nldit (iproc) 
     3083               ilei = nleit (iproc) 
     3084               iilb = nimppt(iproc) 
     3085               DO jj = 1, ijpj 
     3086                  DO ji = ildi, ilei 
     3087                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     3088                  END DO 
     3089               END DO 
     3090            END DO 
     3091         END DO 
     3092          
     3093         DO ji = 1, num_fields 
     3094            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     3095         END DO 
     3096         ! 
     3097         DO jk = 1, num_fields 
     3098            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     3099               ij = jj - nlcj + ijpj 
     3100               DO ji = 1, nlci 
     3101                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     3102               END DO 
     3103            END DO 
     3104         END DO 
     3105         ! 
     3106         ! 
     3107      ENDIF 
     3108      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     3109      DEALLOCATE( ztabl, ztabr ) 
     3110      ! 
     3111   END SUBROUTINE mpp_lbc_north_2d_multiple 
     3112 
     3113 
    29153114   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
    29163115      !!--------------------------------------------------------------------- 
    … …  
    29293128      !!---------------------------------------------------------------------- 
    29303129      REAL(wp), DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj), INTENT(inout) ::   pt2d     ! 2D array with extra halo 
    2931       CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points 
    2932       !                                                                                         !   = T ,  U , V , F or W -points 
    2933       REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! = -1. the sign change across the 
    2934       !!                                                                                        ! north fold, =  1. otherwise 
     3130      CHARACTER(len=1)                                            , INTENT(in   ) ::   cd_type  ! type of input grid-points 
     3131      REAL(wp)                                                    , INTENT(in   ) ::   psgn     ! sign change across the north fold 
     3132      !! 
    29353133      INTEGER ::   ji, jj, jr 
    29363134      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
    29373135      INTEGER ::   ijpj, ij, iproc 
    2938       ! 
    29393136      REAL(wp), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e 
    29403137      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e 
    2941  
    29423138      !!---------------------------------------------------------------------- 
    29433139      ! 
    29443140      ALLOCATE( ztab_e(jpiglo,4+2*jpr2dj), znorthloc_e(jpi,4+2*jpr2dj), znorthgloio_e(jpi,4+2*jpr2dj,jpni) ) 
    2945  
    2946       ! 
    2947       ijpj=4 
    2948       ztab_e(:,:) = 0.e0 
    2949  
    2950       ij=0 
     3141      ! 
     3142      ijpj = 4 
     3143      ztab_e(:,:) = 0._wp 
     3144      ! 
     3145      ij = 0 
    29513146      ! put in znorthloc_e the last 4 jlines of pt2d 
    29523147      DO jj = nlcj - ijpj + 1 - jpr2dj, nlcj +jpr2dj 
    … …  
    30143209      !!---------------------------------------------------------------------- 
    30153210      REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) ::   ptab     ! 3D array on which the boundary condition is applied 
    3016       CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! define the nature of ptab array grid-points 
    3017       !                                                             ! = T , U , V , F , W points 
    3018       REAL(wp)                        , INTENT(in   ) ::   psgn     ! =-1 the sign change across the north fold boundary 
    3019       !                                                             ! =  1. , the sign is kept 
     3211      CHARACTER(len=1)                , INTENT(in   ) ::   cd_type  ! type of ptab grid-points 
     3212      REAL(wp)                        , INTENT(in   ) ::   psgn     ! sign change across the north fold 
    30203213      INTEGER                         , INTENT(in   ) ::   ib_bdy   ! BDY boundary set 
    30213214      ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r6140 r6851  
    198198       
    199199#endif 
    200       IF(lwp) THEN 
    201          WRITE(numout,*) 
    202          WRITE(numout,*) '           defines mpp subdomains' 
    203          WRITE(numout,*) '           ----------------------' 
    204          WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
    205          WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
    206          ifreq = 4 
    207          il1   = 1 
    208          DO jn = 1, (jpni-1)/ifreq+1 
    209             il2 = MIN( jpni, il1+ifreq-1 ) 
    210             WRITE(numout,*) 
    211             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    212             DO jj = jpnj, 1, -1 
    213                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    214                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    215                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    216                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    217             END DO 
    218             WRITE(numout,9201) (ji,ji = il1,il2) 
    219             il1 = il1+ifreq 
    220          END DO 
    221  9200    FORMAT('     ***',20('*************',a3)) 
    222  9203    FORMAT('     *     ',20('         *   ',a3)) 
    223  9201    FORMAT('        ',20('   ',i3,'          ')) 
    224  9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    225       ENDIF 
    226  
    227       zidom = nreci 
    228       DO ji = 1, jpni 
    229          zidom = zidom + ilcit(ji,1) - nreci 
    230       END DO 
    231       IF(lwp) WRITE(numout,*) 
    232       IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
    233        
    234       zjdom = nrecj 
    235       DO jj = 1, jpnj 
    236          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    237       END DO 
    238       IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
    239       IF(lwp) WRITE(numout,*) 
    240        
    241200 
    242201      !  2. Index arrays for subdomains 
    … …  
    301260         nlejt(jn) = nlej 
    302261      END DO 
    303        
    304  
    305       ! 4. From global to local 
     262 
     263      ! 4. Subdomain print 
     264      ! ------------------ 
     265       
     266      IF(lwp) WRITE(numout,*) 
     267      IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
     268      IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
     269      IF(lwp) WRITE(numout,*) 
     270      IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
     271      IF(lwp) WRITE(numout,*) 
     272      IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
     273      zidom = nreci 
     274      DO ji = 1, jpni 
     275         zidom = zidom + ilcit(ji,1) - nreci 
     276      END DO 
     277      IF(lwp) WRITE(numout,*) 
     278      IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
     279 
     280      zjdom = nrecj 
     281      DO jj = 1, jpnj 
     282         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     283      END DO 
     284      IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
     285      IF(lwp) WRITE(numout,*) 
     286 
     287      IF(lwp) THEN 
     288         ifreq = 4 
     289         il1   = 1 
     290         DO jn = 1, (jpni-1)/ifreq+1 
     291            il2 = MIN( jpni, il1+ifreq-1 ) 
     292            WRITE(numout,*) 
     293            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     294            DO jj = jpnj, 1, -1 
     295               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     296               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     297               WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
     298               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     299               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     300            END DO 
     301            WRITE(numout,9201) (ji,ji = il1,il2) 
     302            il1 = il1+ifreq 
     303         END DO 
     304 9200     FORMAT('     ***',20('*************',a3)) 
     305 9203     FORMAT('     *     ',20('         *   ',a3)) 
     306 9201     FORMAT('        ',20('   ',i3,'          ')) 
     307 9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     308 9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
     309      ENDIF 
     310 
     311      ! 5. From global to local 
    306312      ! ----------------------- 
    307313 
    … …  
    310316 
    311317 
    312       ! 5. Subdomain neighbours 
     318      ! 6. Subdomain neighbours 
    313319      ! ---------------------- 
    314320 
    … …  
    433439         WRITE(numout,*) ' nimpp  = ', nimpp 
    434440         WRITE(numout,*) ' njmpp  = ', njmpp 
    435          WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
    436          WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
    437          WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
    438          WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
     441         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     442         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     443         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     444         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     445         WRITE(numout,*) 
    439446      ENDIF 
    440447 
    … …  
    443450      ! Prepare mpp north fold 
    444451 
    445       IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     452      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    446453         CALL mpp_ini_north 
    447       END IF 
     454         IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
     455      ENDIF 
    448456 
    449457      ! Prepare NetCDF output file (if necessary) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r6140 r6851  
    7272 
    7373      ! read namelist for ln_zco 
    74       NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav 
     74      NAMELIST/namzgr/ ln_zco, ln_zps, ln_sco, ln_isfcav, ln_linssh 
    7575 
    7676      !!---------------------------------------------------------------------- 
    … …  
    318318         ENDIF 
    319319 
     320         ! Check wet points over the entire domain to preserve the MPI communication stencil 
    320321         isurf = 0 
    321          DO jj = 1+jprecj, ilj-jprecj 
    322             DO  ji = 1+jpreci, ili-jpreci 
     322         DO jj = 1, ilj 
     323            DO  ji = 1, ili 
    323324               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 
    324325            END DO 
    325326         END DO 
     327 
    326328         IF(isurf /= 0) THEN 
    327329            icont = icont + 1 
    … …  
    333335 
    334336      nfipproc(:,:) = ipproc(:,:) 
    335  
    336337 
    337338      ! Control 
    … …  
    441442      ii = iin(narea) 
    442443      ij = ijn(narea) 
     444 
     445      ! set default neighbours 
     446      noso = ioso(ii,ij) 
     447      nowe = iowe(ii,ij) 
     448      noea = ioea(ii,ij) 
     449      nono = iono(ii,ij)  
     450      npse = iose(ii,ij) 
     451      npsw = iosw(ii,ij) 
     452      npne = ione(ii,ij) 
     453      npnw = ionw(ii,ij) 
     454 
     455      ! check neighbours location 
    443456      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    444457         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    511524      IF (lwp) THEN 
    512525         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
     526         WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    513527         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    514528         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    523537      END IF 
    524538 
    525       IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
    526  
    527       ! Prepare mpp north fold 
    528  
    529       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    530          CALL mpp_ini_north 
    531          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    532       ENDIF 
    533  
    534539      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    535540      ! In this case the important thing is that npolj /= 0 
    … …  
    548553      ENDIF 
    549554 
     555      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     556 
     557      IF(lwp) THEN 
     558         WRITE(numout,*) ' nproc  = ', nproc 
     559         WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
     560         WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
     561         WRITE(numout,*) ' nbondi = ', nbondi 
     562         WRITE(numout,*) ' nbondj = ', nbondj 
     563         WRITE(numout,*) ' npolj  = ', npolj 
     564         WRITE(numout,*) ' nperio = ', nperio 
     565         WRITE(numout,*) ' nlci   = ', nlci 
     566         WRITE(numout,*) ' nlcj   = ', nlcj 
     567         WRITE(numout,*) ' nimpp  = ', nimpp 
     568         WRITE(numout,*) ' njmpp  = ', njmpp 
     569         WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
     570         WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
     571         WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
     572         WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
     573         WRITE(numout,*) 
     574      ENDIF 
     575 
     576      IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
     577 
     578      ! Prepare mpp north fold 
     579 
     580      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     581         CALL mpp_ini_north 
     582         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     583      ENDIF 
     584 
    550585      ! Prepare NetCDF output file (if necessary) 
    551586      CALL mpp_init_ioipsl 
    552587 
    553       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    554  
    555       IF(lwp) THEN 
    556          WRITE(numout,*) ' nproc=  ',nproc 
    557          WRITE(numout,*) ' nowe=   ',nowe 
    558          WRITE(numout,*) ' noea=   ',noea 
    559          WRITE(numout,*) ' nono=   ',nono 
    560          WRITE(numout,*) ' noso=   ',noso 
    561          WRITE(numout,*) ' nbondi= ',nbondi 
    562          WRITE(numout,*) ' nbondj= ',nbondj 
    563          WRITE(numout,*) ' npolj=  ',npolj 
    564          WRITE(numout,*) ' nperio= ',nperio 
    565          WRITE(numout,*) ' nlci=   ',nlci 
    566          WRITE(numout,*) ' nlcj=   ',nlcj 
    567          WRITE(numout,*) ' nimpp=  ',nimpp 
    568          WRITE(numout,*) ' njmpp=  ',njmpp 
    569          WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
    570          WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
    571          WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
    572          WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
    573       ENDIF 
    574588 
    575589   END SUBROUTINE mpp_init2 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6140 r6851  
    184184         DO jj = 2, jpjm1 
    185185            DO ji = fs_2, fs_jpim1   ! vector opt. 
    186                zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt(ji,jj), hmlpt(ji+1,jj  ), 5._wp)      & 
    187                   &                                  - 0.5_wp * ( risfdep(ji,jj) + risfdep(ji+1,jj  ) ) ) 
    188                zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt(ji,jj), hmlpt(ji  ,jj+1), 5._wp)      & 
    189                   &                                  - 0.5_wp * ( risfdep(ji,jj) + risfdep(ji  ,jj+1) ) ) 
     186               zslpml_hmlpu(ji,jj) = uslpml(ji,jj) / ( MAX(hmlpt  (ji,jj), hmlpt  (ji+1,jj  ), 5._wp) & 
     187                  &                                  - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       ) )  
     188               zslpml_hmlpv(ji,jj) = vslpml(ji,jj) / ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp) & 
     189                  &                                  - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)      ) ) 
    190190            END DO 
    191191         END DO 
    … …  
    215215               zfj = MAX( omlmask(ji,jj,jk), omlmask(ji,jj+1,jk) ) 
    216216               ! thickness of water column between surface and level k at u/v point 
    217                zdepu = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji+1,jj  ,jk) )                            & 
    218                                 - ( risfdep(ji,jj)    + risfdep(ji+1,jj)    ) - e3u_n(ji,jj,miku(ji,jj)) ) 
    219                zdepv = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji,jj+1,jk) )                              & 
    220                                 - ( risfdep(ji,jj)    + risfdep(ji,jj+1)    ) - e3v_n(ji,jj,mikv(ji,jj)) ) 
     217               zdepu = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji+1,jj,jk) )                            & 
     218                  &             - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) - e3u_n(ji,jj,miku(ji,jj))  ) 
     219               zdepv = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji,jj+1,jk) )                            & 
     220                  &             - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) - e3v_n(ji,jj,mikv(ji,jj))  ) 
    221221               ! 
    222222               zwz(ji,jj,jk) = ( ( 1._wp - zfi) * zau / ( zbu - zeps )                                     & 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r5407 r6851  
    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/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

    r5836 r6851  
    668668      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    669669 
     670      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     671      DO jl = 1, jpl 
     672         qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     673                                   ! but then qemp_ice should also include sublimation  
     674      END DO 
     675 
    670676      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  
    671677#endif 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6140 r6851  
    206206      IF( MOD( kt - 1, nn_fsbc ) == 0 )   THEN 
    207207         qlw_ice(:,:,1)   = sf(jp_qlw)%fnow(:,:,1)  
    208          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 
    209211         tatm_ice(:,:)    = sf(jp_tair)%fnow(:,:,1)          
    210212         qatm_ice(:,:)    = sf(jp_humi)%fnow(:,:,1) 
    … …  
    612614      ! --- evaporation --- ! 
    613615      z1_lsub = 1._wp / Lsub 
    614       evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
    615       devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
    616       zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
     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 
    617619 
    618620      ! --- evaporation minus precipitation --- ! 
    … …  
    637639      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    638640      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
     641 
     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 
    639647 
    640648      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r6165 r6851  
    10061006      IF( srcv(jpr_toce)%laction ) THEN                      ! received by sas in case of opa <-> sas coupling 
    10071007         sst_m(:,:) = frcv(jpr_toce)%z3(:,:,1) 
    1008          IF( srcv(jpr_soce)%laction .AND. ln_useCT ) THEN    ! make sure that sst_m is the potential temperature 
     1008         IF( srcv(jpr_soce)%laction .AND. l_useCT ) THEN    ! make sure that sst_m is the potential temperature 
    10091009            sst_m(:,:) = eos_pt_from_ct( sst_m(:,:), sss_m(:,:) ) 
    10101010         ENDIF 
    … …  
    13271327      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13281328      !! 
    1329       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1330       !!              ocean-ice system. 
     1329      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13311330      !! 
    13321331      !! ** Method  :   transform the fields received from the atmosphere into 
    … …  
    13391338      !!             emp_ice = sublimation - solid precipitation as liquid 
    13401339      !!             precipitation are re-routed directly to the ocean and  
    1341       !!             runoffs and calving directly enter the ocean. 
     1340      !!             calving directly enter the ocean (runoffs are read but  
     1341      !!             included in trasbc.F90) 
    13421342      !!              * solid precipitation (sprecip), used to add to qns_tot  
    13431343      !!             the heat lost associated to melting solid precipitation 
    13441344      !!             over the ocean fraction. 
    1345       !!       ===>> CAUTION here this changes the net heat flux received from 
    1346       !!             the atmosphere 
    1347       !! 
    1348       !!                  - the fluxes have been separated from the stress as 
    1349       !!                 (a) they are updated at each ice time step compare to 
    1350       !!                 an update at each coupled time step for the stress, and 
    1351       !!                 (b) the conservative computation of the fluxes over the 
    1352       !!                 sea-ice area requires the knowledge of the ice fraction 
    1353       !!                 after the ice advection and before the ice thermodynamics, 
    1354       !!                 so that the stress is updated before the ice dynamics 
    1355       !!                 while the fluxes are updated after it. 
     1345      !!               * heat content of rain, snow and evap can also be provided, 
     1346      !!             otherwise heat flux associated with these mass flux are 
     1347      !!             guessed (qemp_oce, qemp_ice) 
     1348      !! 
     1349      !!             - the fluxes have been separated from the stress as 
     1350      !!               (a) they are updated at each ice time step compare to 
     1351      !!               an update at each coupled time step for the stress, and 
     1352      !!               (b) the conservative computation of the fluxes over the 
     1353      !!               sea-ice area requires the knowledge of the ice fraction 
     1354      !!               after the ice advection and before the ice thermodynamics, 
     1355      !!               so that the stress is updated before the ice dynamics 
     1356      !!               while the fluxes are updated after it. 
     1357      !! 
     1358      !! ** Details 
     1359      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1360      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1361      !! 
     1362      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1363      !! 
     1364      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1365      !!                                                                      river runoff (rnf) is provided but not included here 
    13561366      !! 
    13571367      !! ** Action  :   update at each nf_ice time step: 
    13581368      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13591369      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice 
    1360       !!                   emp_tot            total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 
    1361       !!                   emp_ice            ice sublimation - solid precipitation over the ice 
    1362       !!                   dqns_ice           d(non-solar heat flux)/d(Temperature) over the ice 
    1363       !!                   sprecip             solid precipitation over the ocean   
     1370      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1371      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1372      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1373      !!                   sprecip           solid precipitation over the ocean   
    13641374      !!---------------------------------------------------------------------- 
    13651375      REAL(wp), INTENT(in   ), DIMENSION(:,:)             ::   p_frld  ! lead fraction            [0 to 1] 
    … …  
    13701380      ! 
    13711381      INTEGER ::   jl   ! dummy loop index 
    1372       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
    1373       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
    1374       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
    1375       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
     1382      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
     1383      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
     1384      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
     1385      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
    13761386      !!---------------------------------------------------------------------- 
    13771387      ! 
    13781388      IF( nn_timing == 1 )   CALL timing_start('sbc_cpl_ice_flx') 
    13791389      ! 
    1380       CALL wrk_alloc( jpi,jpj,       zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1381       CALL wrk_alloc( jpi,jpj,jpl,   zqns_ice, zqsr_ice, zdqns_ice ) 
     1390      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1391      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1392      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1393      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    13821394 
    13831395      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    13861398      ! 
    13871399      !                                                      ! ========================= ! 
    1388       !                                                      !    freshwater budget      !   (emp) 
     1400      !                                                      !    freshwater budget      ! 
    13891401      !                                                      ! ========================= ! 
    13901402      ! 
    1391       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1392       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1393       !                                                           ! solid Precipitation                     (sprecip) 
    1394       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1403      !                                                           ! solid Precipitation                                (sprecip) 
     1404      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1405      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1406      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    13951407      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    1396       CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1397          zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    1398          ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    1399          zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1400          zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    1401             CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1)              )   ! liquid precipitation  
     1408      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
     1409         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1410         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
     1411         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1412         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1413               CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
    14021414         IF( iom_use('hflx_rain_cea') )   & 
    1403             CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from liq. precip.  
    1404          IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') )   & 
    1405             ztmp(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1415            &  CALL iom_put( 'hflx_rain_cea',   frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:)                                            )  ! heat flux from liq. precip.  
    14061416         IF( iom_use('evap_ao_cea'  ) )   & 
    1407             CALL iom_put( 'evap_ao_cea'  , ztmp                   )   ! ice-free oce evap (cell average) 
     1417            &  CALL iom_put( 'evap_ao_cea'  ,   frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:)                )  ! ice-free oce evap (cell average) 
    14081418         IF( iom_use('hflx_evap_cea') )   & 
    1409             CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * zcptn(:,:) )   ! heat flux from from evap (cell average) 
    1410       CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
     1419            &  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) 
     1420      CASE( 'oce and ice' )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14111421         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1412          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1422         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14131423         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14141424         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
    14151425      END SELECT 
    14161426 
    1417       IF( iom_use('subl_ai_cea') )   & 
    1418          CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
    1419       !    
    1420       !                                                           ! runoffs and calving (put in emp_tot) 
     1427#if defined key_lim3 
     1428      ! zsnw = snow fraction over ice after wind blowing 
     1429      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
     1430       
     1431      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1432      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1433      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1434 
     1435      ! --- evaporation over ocean (used later for qemp) --- ! 
     1436      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1437 
     1438      ! --- evaporation over ice (kg/m2/s) --- ! 
     1439      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
     1440      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     1441      ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
     1442      zdevap_ice(:,:) = 0._wp 
     1443       
     1444      ! --- runoffs (included in emp later on) --- ! 
     1445      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1446 
     1447      ! --- calving (put in emp_tot and emp_oce) --- ! 
     1448      IF( srcv(jpr_cal)%laction ) THEN  
     1449         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1450         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1451         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
     1452      ENDIF 
     1453 
     1454      IF( ln_mixcpl ) THEN 
     1455         emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
     1456         emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
     1457         emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
     1458         sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
     1459         tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
     1460         DO jl=1,jpl 
     1461            evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
     1462            devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
     1463         ENDDO 
     1464      ELSE 
     1465         emp_tot(:,:) =         zemp_tot(:,:) 
     1466         emp_ice(:,:) =         zemp_ice(:,:) 
     1467         emp_oce(:,:) =         zemp_oce(:,:)      
     1468         sprecip(:,:) =         zsprecip(:,:) 
     1469         tprecip(:,:) =         ztprecip(:,:) 
     1470         DO jl=1,jpl 
     1471            evap_ice (:,:,jl) = zevap_ice (:,:) 
     1472            devap_ice(:,:,jl) = zdevap_ice(:,:) 
     1473         ENDDO 
     1474      ENDIF 
     1475 
     1476      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1477                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1478      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1479      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
     1480#else 
     1481      ! runoffs and calving (put in emp_tot) 
    14211482      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    14221483      IF( srcv(jpr_cal)%laction ) THEN  
    … …  
    14371498      ENDIF 
    14381499 
    1439          CALL iom_put( 'snowpre'    , sprecip                                )   ! Snow 
    1440       IF( iom_use('snow_ao_cea') )   & 
    1441          CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:)             )   ! Snow        over ice-free ocean  (cell average) 
    1442       IF( iom_use('snow_ai_cea') )   & 
    1443          CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
     1500      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1501                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1502      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1503      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
     1504#endif 
    14441505 
    14451506      !                                                      ! ========================= ! 
    14461507      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    14471508      !                                                      ! ========================= ! 
    1448       CASE( 'oce only' )                                     ! the required field is directly provided 
    1449          zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    1450       CASE( 'conservative' )                                      ! the required fields are directly provided 
    1451          zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1509      CASE( 'oce only' )         ! the required field is directly provided 
     1510         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1511      CASE( 'conservative' )     ! the required fields are directly provided 
     1512         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14521513         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14531514            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    14541515         ELSE 
    1455             ! Set all category values equal for the moment 
    14561516            DO jl=1,jpl 
    1457                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1517               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    14581518            ENDDO 
    14591519         ENDIF 
    1460       CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1461          zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1520      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1521         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    14621522         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    14631523            DO jl=1,jpl 
    … …  
    14661526            ENDDO 
    14671527         ELSE 
    1468             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1528            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    14691529            DO jl=1,jpl 
    14701530               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    … …  
    14721532            ENDDO 
    14731533         ENDIF 
    1474       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1534      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    14751535! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    14761536         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    14771537         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    14781538            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1479             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1539            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    14801540      END SELECT 
    14811541!!gm 
    … …  
    14871547!! similar job should be done for snow and precipitation temperature 
    14881548      !                                      
    1489       IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    1490          ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1491          zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    1492          IF( iom_use('hflx_cal_cea') )   & 
    1493             CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    1494       ENDIF 
    1495  
    1496       ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
    1497       IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    1498  
    1499 #if defined key_lim3 
    1500       CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
    1501  
    1502       ! --- evaporation --- ! 
    1503       ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
    1504       ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
    1505       !                 but it is incoherent WITH the ice model   
    1506       DO jl=1,jpl 
    1507          evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
    1508       ENDDO 
    1509       zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
    1510  
    1511       ! --- evaporation minus precipitation --- ! 
    1512       emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
    1513  
     1549      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1550         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1551                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1552         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1553      ENDIF 
     1554 
     1555#if defined key_lim3       
    15141556      ! --- non solar flux over ocean --- ! 
    15151557      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    15171559      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15181560 
    1519       ! --- heat flux associated with emp --- ! 
    1520       zsnw(:,:) = 0._wp 
    1521       CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
    1522       zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    1523          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    1524          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
    1525       qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    1526          &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1527  
    1528       ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1561      ! --- heat flux associated with emp (W/m2) --- ! 
     1562      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1563         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1564         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
     1565!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1566!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1567      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
     1568                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
     1569       
     1570      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15291571      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15301572 
    1531       ! --- total non solar flux --- ! 
    1532       zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
     1573      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
     1574      DO jl = 1, jpl 
     1575         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
     1576      END DO 
     1577 
     1578      ! --- total non solar flux (including evap/precip) --- ! 
     1579      zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
    15331580 
    15341581      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15371584         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15381585         DO jl=1,jpl 
    1539             qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
     1586            qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
     1587            qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
    15401588         ENDDO 
    15411589         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15421590         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1543 !!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
     1591         qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
    15441592      ELSE 
    15451593         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    15461594         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    15471595         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
    1548          qprec_ice(:,:)   = zqprec_ice(:,:) 
    1549          qemp_oce (:,:)   = zqemp_oce (:,:) 
    1550       ENDIF 
    1551  
    1552       CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1596         qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
     1597         qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
     1598         qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
     1599         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
     1600      ENDIF 
     1601 
     1602      !! clem: we should output qemp_oce and qemp_ice (at least) 
     1603      IF( iom_use('hflx_snow_cea') )   CALL iom_put( 'hflx_snow_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) )   ! heat flux from snow (cell average) 
     1604      !! these diags are not outputed yet 
     1605!!      IF( iom_use('hflx_rain_cea') )   CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )   ! heat flux from rain (cell average) 
     1606!!      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) 
     1607!!      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put( 'hflx_snow_ai_cea', sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) ) ! heat flux from snow (cell average) 
     1608 
    15531609#else 
    1554       ! 
    1555       ! clem: this formulation is certainly wrong... but better than it was before... 
     1610      ! clem: this formulation is certainly wrong... but better than it was... 
    15561611      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    15571612         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    15581613         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1559          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1614         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    15601615 
    15611616     IF( ln_mixcpl ) THEN 
    … …  
    15691624         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    15701625      ENDIF 
    1571       ! 
    15721626#endif 
     1627 
    15731628      !                                                      ! ========================= ! 
    15741629      SELECT CASE( TRIM( sn_rcv_qsr%cldes ) )                !      solar heat fluxes    !   (qsr) 
    … …  
    16191674 
    16201675#if defined key_lim3 
    1621       CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16221676      ! --- solar flux over ocean --- ! 
    16231677      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16271681      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16281682      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
    1629  
    1630       CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16311683#endif 
    16321684 
    … …  
    16791731      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    16801732 
    1681       CALL wrk_dealloc( jpi,jpj,       zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
    1682       CALL wrk_dealloc( jpi,jpj,jpl,   zqns_ice, zqsr_ice, zdqns_ice ) 
     1733      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
     1734      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
     1735      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
     1736      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
    16831737      ! 
    16841738      IF( nn_timing == 1 )   CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17191773          
    17201774         IF ( nn_components == jp_iam_opa ) THEN 
    1721             ztmp1(:,:) = tsn(:,:,1,jp_tem)   ! send temperature as it is (potential or conservative) -> use of ln_useCT on the received part 
     1775            ztmp1(:,:) = tsn(:,:,1,jp_tem)   ! send temperature as it is (potential or conservative) -> use of l_useCT on the received part 
    17221776         ELSE 
    17231777            ! we must send the surface potential temperature  
    1724             IF( ln_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     1778            IF( l_useCT )  THEN    ;   ztmp1(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
    17251779            ELSE                    ;   ztmp1(:,:) = tsn(:,:,1,jp_tem) 
    17261780            ENDIF 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r6140 r6851  
    104104      INTEGER, INTENT(in) ::   kblk    ! type of bulk (=3 CLIO, =4 CORE, =5 COUPLED) 
    105105      !! 
    106       INTEGER  ::   jl                 ! dummy loop index 
    107       REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
    108       REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    109       REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    110       !!---------------------------------------------------------------------- 
    111  
    112       IF( nn_timing == 1 )  CALL timing_start('sbc_ice_lim') 
     106      INTEGER  ::   jl   ! dummy loop index 
     107      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_os  , zalb_cs    ! ice albedo under overcast/clear sky 
     108      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zutau_ice, zvtau_ice  
     109      !!---------------------------------------------------------------------- 
     110 
     111      IF( nn_timing == 1 )   CALL timing_start('sbc_ice_lim') 
    113112 
    114113      !-----------------------! 
    … …  
    193192         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    194193         !---------------------------------------------------------------------------------------- 
    195          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     194         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    196195         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    197196 
    … …  
    199198         CASE( jp_clio )                                       ! CLIO bulk formulation 
    200199            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    201             ! (zalb_ice) is computed within the bulk routine 
    202             CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
    203             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    204             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     200            ! (alb_ice) is computed within the bulk routine 
     201                                 CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 
     202            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     203            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    205204         CASE( jp_core )                                       ! CORE bulk formulation 
    206205            ! albedo depends on cloud fraction because of non-linear spectral effects 
    207             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    208             CALL blk_ice_core_flx( t_su, zalb_ice ) 
    209             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    210             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     206            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     207                                 CALL blk_ice_core_flx( t_su, alb_ice ) 
     208            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     209            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    211210         CASE ( jp_purecpl ) 
    212211            ! albedo depends on cloud fraction because of non-linear spectral effects 
    213             zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    214                                  CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
    215             ! clem: evap_ice is forced to 0 in coupled mode for now  
    216             !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
    217             evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
    218             IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     212            alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     213                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
     214            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    219215         END SELECT 
    220          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
     216         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
    221217 
    222218         !----------------------------! 
    … …  
    260256      !! ** purpose :   Allocate all the dynamic arrays of the LIM-3 modules 
    261257      !!---------------------------------------------------------------------- 
    262       INTEGER :: ierr 
     258      INTEGER :: ji, jj, ierr 
    263259      !!---------------------------------------------------------------------- 
    264260      IF(lwp) WRITE(numout,*) 
    … …  
    317313      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
    318314      ! 
     315      DO jj = 1, jpj 
     316         DO ji = 1, jpi 
     317            IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
     318            ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
     319            ENDIF 
     320        ENDDO 
     321      ENDDO  
     322      ! 
    319323      nstart = numit  + nn_fsbc       
    320324      nitrun = nitend - nit000 + 1  
    … …  
    339343      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    340344      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
    341          &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     345         &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    342346      !!------------------------------------------------------------------- 
    343347      !                     
    … …  
    359363         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    360364         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    361          WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
     365         WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
     366         WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
    362367         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    363368         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    568573      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    569574      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    570       sfx_res(:,:) = 0._wp 
     575      sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
    571576      ! 
    572577      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    584589      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    585590      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    586       hfx_err_dif(:,:) = 0._wp   ; 
     591      hfx_err_dif(:,:) = 0._wp 
     592      wfx_err_sub(:,:) = 0._wp 
    587593      ! 
    588594      afx_tot(:,:) = 0._wp   ; 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r6140 r6851  
    323323         emp_b (:,:) = emp (:,:) 
    324324         sfx_b (:,:) = sfx (:,:) 
     325         IF ( ln_rnf ) THEN 
     326            rnf_b    (:,:  ) = rnf    (:,:  ) 
     327            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     328         ENDIF 
    325329      ENDIF 
    326330      !                                            ! ---------------------------------------- ! 
    … …  
    430434      !                                                ! ---------------------------------------- ! 
    431435      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    432          CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
     436         CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
     437         CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
    433438         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    434439                                                                ! (includes virtual salt flux beneath ice  

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r6140 r6851  
    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   ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/SBC/sbcssm.F90

    r6140 r6851  
    7070         ssu_m(:,:) = ub(:,:,1) 
    7171         ssv_m(:,:) = vb(:,:,1) 
    72          IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    73          ELSE                    ;   sst_m(:,:) = zts(:,:,jp_tem) 
     72         IF( l_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
     73         ELSE                   ;   sst_m(:,:) = zts(:,:,jp_tem) 
    7474         ENDIF 
    7575         sss_m(:,:) = zts(:,:,jp_sal) 
    … …  
    9292            ssu_m(:,:) = zcoef * ub(:,:,1) 
    9393            ssv_m(:,:) = zcoef * vb(:,:,1) 
    94             IF( ln_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    95             ELSE                    ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem) 
     94            IF( l_useCT )  THEN    ;   sst_m(:,:) = zcoef * eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
     95            ELSE                   ;   sst_m(:,:) = zcoef * zts(:,:,jp_tem) 
    9696            ENDIF 
    9797            sss_m(:,:) = zcoef * zts(:,:,jp_sal) 
    … …  
    120120         ssu_m(:,:) = ssu_m(:,:) + ub(:,:,1) 
    121121         ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) 
    122          IF( ln_useCT )  THEN    ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
    123          ELSE                    ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 
     122         IF( l_useCT )  THEN    ;   sst_m(:,:) = sst_m(:,:) + eos_pt_from_ct( zts(:,:,jp_tem), zts(:,:,jp_sal) ) 
     123         ELSE                   ;   sst_m(:,:) = sst_m(:,:) + zts(:,:,jp_tem) 
    124124         ENDIF 
    125125         sss_m(:,:) = sss_m(:,:) + zts(:,:,jp_sal) 
    … …  
    241241         ssu_m(:,:) = ub(:,:,1) 
    242242         ssv_m(:,:) = vb(:,:,1) 
    243          IF( ln_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
    244          ELSE                    ;   sst_m(:,:) = tsn(:,:,1,jp_tem) 
     243         IF( l_useCT )  THEN    ;   sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) 
     244         ELSE                   ;   sst_m(:,:) = tsn(:,:,1,jp_tem) 
    245245         ENDIF 
    246246         sss_m(:,:) = tsn  (:,:,1,jp_sal) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6140 r6851  
    2222   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
    2323   !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
     24   !!             -   ! 2016-04  (F. Roquet) modify S-EOS as in Roquet et al. (JPO, 2015) + L-EOS 
     25   !!             -   ! 2016-04  (T. Graham, G. Madec) logicals instead of an integer as control of the EOS used 
     26   !!             -   ! 2016-07  (G. Madec, F. Roquet) generic freezing point for all EOS 
    2427   !!---------------------------------------------------------------------- 
    2528 
    2629   !!---------------------------------------------------------------------- 
    2730   !!   eos           : generic interface of the equation of state 
    28    !!   eos_insitu    : Compute the in situ density 
    29    !!   eos_insitu_pot: Compute the insitu and surface referenced potential volumic mass 
    30    !!   eos_insitu_2d : Compute the in situ density for 2d fields 
    31    !!   bn2           : Compute the Brunt-Vaisala frequency 
     31   !!   eos_insitu    : compute the in situ density 
     32   !!   eos_insitu_pot: compute the insitu and surface referenced potential volumic mass 
     33   !!   eos_insitu_2d : compute the in situ density for 2d fields 
    3234   !!   eos_rab       : generic interface of in situ thermal/haline expansion ratio  
    3335   !!   eos_rab_3d    : compute in situ thermal/haline expansion ratio 
    3436   !!   eos_rab_2d    : compute in situ thermal/haline expansion ratio for 2d fields 
     37   !!   bn2           : compute the Brunt-Vaisala frequency 
     38   !!   eos_pt_from_ct: compute potential temperature from conservative temperature 
    3539   !!   eos_fzp_2d    : freezing temperature for 2d fields 
    3640   !!   eos_fzp_0d    : freezing temperature for scalar 
     41   !!   eos_pen       : Potential Energy diagnostics 
    3742   !!   eos_init      : set eos parameters (namelist) 
    3843   !!---------------------------------------------------------------------- 
    … …  
    7580 
    7681   !                               !!** Namelist nameos ** 
    77    INTEGER , PUBLIC ::   nn_eos     ! = 0/1/2 type of eq. of state and Brunt-Vaisala frequ. 
    78    LOGICAL , PUBLIC ::   ln_useCT   ! determine if eos_pt_from_ct is used to compute sst_m 
    79  
    80    !                               !!!  simplified eos coefficients (default value: Vallis 2006) 
    81    REAL(wp) ::   rn_a0      = 1.6550e-1_wp     ! thermal expansion coeff.  
    82    REAL(wp) ::   rn_b0      = 7.6554e-1_wp     ! saline  expansion coeff.  
    83    REAL(wp) ::   rn_lambda1 = 5.9520e-2_wp     ! cabbeling coeff. in T^2         
    84    REAL(wp) ::   rn_lambda2 = 5.4914e-4_wp     ! cabbeling coeff. in S^2         
    85    REAL(wp) ::   rn_mu1     = 1.4970e-4_wp     ! thermobaric coeff. in T   
    86    REAL(wp) ::   rn_mu2     = 1.1090e-5_wp     ! thermobaric coeff. in S   
    87    REAL(wp) ::   rn_nu      = 2.4341e-3_wp     ! cabbeling coeff. in theta*salt   
     82   !                                ! Choice of Equation Of Seawater (EOS) 
     83   LOGICAL , PUBLIC ::   ln_TEOS10     ! use the polyTEOS-10 EOS 
     84   LOGICAL , PUBLIC ::   ln_EOS80      ! use the polyEOS-80  EOS 
     85   LOGICAL , PUBLIC ::   ln_SEOS       ! use the Simplified EOS (Roquet et al. JPO 2015) 
     86   LOGICAL , PUBLIC ::   ln_LEOS       ! use a   Linear     EOS 
     87   !                                ! S-EOS coefficients (default value see Roquet et al. JPO 2015, Eq.17) 
     88   REAL(wp) ::   rn_a0, rn_b0, rn_cb, rn_t0, rn_th 
     89   REAL(wp) ::   rn_al, rn_bl       ! L-EOS coefficients 
     90 
     91   LOGICAL , PUBLIC    ::   l_useCT         ! =T in ln_TEOS10, ln_SEOS or ln_LEOS=T (i.e. use eos_pt_from_ct to compute sst_m), =F otherwise 
     92   INTEGER , PUBLIC    ::   neos            ! Identifier for equation of state used 
     93   INTEGER , PARAMETER ::   np_teos10 = -1  ! parameter for using TEOS-10 
     94   INTEGER , PARAMETER ::   np_eos80  =  0  ! parameter for using EOS-80 
     95   INTEGER , PARAMETER ::   np_seos   =  1  ! parameter for using Simplified EOS 
     96   INTEGER , PARAMETER ::   np_leos   =  2  ! parameter for using Linear     EOS 
     97 
     98   ! All EOS 
     99   REAL(wp) ::   rSA2SP    ! conversion factor from SA to SP (set to 1 for EOS-80) 
    88100    
    89101   ! TEOS10/EOS80 parameters 
    … …  
    169181   REAL(wp) ::   BPE002 
    170182 
     183   ! S-EOS (L-EOS) parameters 
     184   REAL(wp) ::   SA0, SB0 , SCB , STH , ST0 
     185    
    171186   !! * Substitutions 
    172187#  include "vectopt_loop_substitute.h90" 
    … …  
    184199      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
    185200      !!       potential temperature and salinity using an equation of state 
    186       !!       defined through the namelist parameter nn_eos. 
     201      !!       selected in the nameos namelist 
    187202      !! 
    188203      !! ** Method  :   prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 
    … …  
    194209      !!                rau0   reference density            kg/m^3 
    195210      !! 
    196       !!     nn_eos = -1 : polynomial TEOS-10 equation of state is used for rho(t,s,z). 
     211      !!     ln_TEOS10 : polynomial TEOS-10 Equation of Seawater is used for rho(t,s,z). 
    197212      !!         Check value: rho = 1028.21993233072 kg/m^3 for z=3000 dbar, ct=3 Celcius, sa=35.5 g/kg 
    198213      !! 
    199       !!     nn_eos =  0 : polynomial EOS-80 equation of state is used for rho(t,s,z). 
     214      !!     ln_EOS80  : polynomial EOS-80 Equation of Seawater is used for rho(t,s,z). 
    200215      !!         Check value: rho = 1028.35011066567 kg/m^3 for z=3000 dbar, pt=3 Celcius, sp=35.5 psu 
    201216      !! 
    202       !!     nn_eos =  1 : simplified equation of state 
    203       !!              prd(t,s,z) = ( -a0*(1+lambda/2*(T-T0)+mu*z+nu*(S-S0))*(T-T0) + b0*(S-S0) ) / rau0 
    204       !!              linear case function of T only: rn_alpha<>0, other coefficients = 0 
    205       !!              linear eos function of T and S: rn_alpha and rn_beta<>0, other coefficients=0 
    206       !!              Vallis like equation: use default values of coefficients 
     217      !!     ln_SEOS   : simplified Equation of Seawater (Eq. (17) of Roquet et al. JPO 2015) 
     218      !!                     rd(T,S,Z) = [-(a0+.5*cb*(T-T0)+th*Z)*(T-T0) + b0*(S-35) ] / rau0 
     219      !! 
     220      !!     ln_LEOS   : linear Equation of Seawater 
     221      !!                     rd(T,S,Z) = [ -al*(T-10) + bl*(S-35) ] / rau0 
     222      !! 
     223      !!     Note that both TEOS-10 and EOS-80 share a same polynomial expression 
     224      !!     Note that both S-EOS   and L-EOS  share a same polynomial expression  
    207225      !! 
    208226      !! ** Action  :   compute prd , the in situ density (no units) 
    209227      !! 
    210       !! References :   Roquet et al, Ocean Modelling, in preparation (2014) 
    211       !!                Vallis, Atmospheric and Oceanic Fluid Dynamics, 2006 
     228      !! References :   Roquet et al. 2015, Ocean Modelling. 
     229      !!                Roquet et al. 2015, J. Phys. Oceanogr.  
    212230      !!                TEOS-10 Manual, 2010 
    213231      !!---------------------------------------------------------------------- 
    … …  
    224242      IF( nn_timing == 1 )   CALL timing_start('eos-insitu') 
    225243      ! 
    226       SELECT CASE( nn_eos ) 
    227       ! 
    228       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     244      SELECT CASE( neos ) 
     245      ! 
     246      CASE( np_teos10 , np_eos80 )        !==  polynomial TEOS-10 or EOS-80 ==! 
    229247         ! 
    230248         DO jk = 1, jpkm1 
    … …  
    266284         END DO 
    267285         ! 
    268       CASE( 1 )                !==  simplified EOS  ==! 
     286      CASE( np_seos , np_leos )           !==  simplified or linear EOS  ==! 
    269287         ! 
    270288         DO jk = 1, jpkm1 
    271289            DO jj = 1, jpj 
    272290               DO ji = 1, jpi 
    273                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     291                  zt  = pts  (ji,jj,jk,jp_tem) - ST0 
    274292                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    275293                  zh  = pdep (ji,jj,jk) 
    276294                  ztm = tmask(ji,jj,jk) 
    277295                  ! 
    278                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    279                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    280                      &  - rn_nu * zt * zs 
    281                      !                                  
     296                  zn =  - ( SA0 + 0.5_wp*SCB * zt + STH * zh ) * zt + SB0 * zs 
     297                  !                                  
    282298                  prd(ji,jj,jk) = zn * r1_rau0 * ztm                ! density anomaly (masked) 
    283299               END DO 
    … …  
    299315      !! 
    300316      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) and the 
    301       !!      potential volumic mass (Kg/m3) from potential temperature and 
    302       !!      salinity fields using an equation of state defined through the 
    303       !!     namelist parameter nn_eos. 
     317      !!      potential density (kg/m3) from temperature and salinity 
     318      !!       fields using the equation of state selected in the namelist. 
    304319      !! 
    305320      !! ** Action  : - prd  , the in situ density (no units) 
    306       !!              - prhop, the potential volumic mass (Kg/m3) 
    307       !! 
     321      !!              - prhop, the potential density (kg/m3) 
    308322      !!---------------------------------------------------------------------- 
    309323      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts    ! 1 : potential temperature  [Celcius] 
    … …  
    322336      IF( nn_timing == 1 )   CALL timing_start('eos-pot') 
    323337      ! 
    324       SELECT CASE ( nn_eos ) 
    325       ! 
    326       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     338      SELECT CASE ( neos ) 
     339      ! 
     340      CASE( np_teos10 , np_eos80 )               !==  polynomial TEOS-10 or EOS-80 ==! 
    327341         ! 
    328342         ! Stochastic equation of state 
    329343         IF ( ln_sto_eos ) THEN 
    330             ALLOCATE(zn0_sto(1:2*nn_sto_eos)) 
    331             ALLOCATE(zn_sto(1:2*nn_sto_eos)) 
    332             ALLOCATE(zsign(1:2*nn_sto_eos)) 
     344            ALLOCATE( zn0_sto(1:2*nn_sto_eos) ) 
     345            ALLOCATE( zn_sto (1:2*nn_sto_eos) ) 
     346            ALLOCATE( zsign  (1:2*nn_sto_eos) ) 
    333347            DO jsmp = 1, 2*nn_sto_eos, 2 
    334348              zsign(jsmp)   = 1._wp 
    … …  
    387401               END DO 
    388402            END DO 
    389             DEALLOCATE(zn0_sto,zn_sto,zsign) 
    390          ! Non-stochastic equation of state 
    391          ELSE 
     403            DEALLOCATE( zn0_sto, zn_sto, zsign ) 
     404            !  
     405         ELSE                    ! Non-stochastic equation of state 
    392406            DO jk = 1, jpkm1 
    393407               DO jj = 1, jpj 
    … …  
    430444         ENDIF 
    431445          
    432       CASE( 1 )                !==  simplified EOS  ==! 
     446      CASE( np_seos , np_leos )                !==  simplified or linear EOS  ==! 
    433447         ! 
    434448         DO jk = 1, jpkm1 
    435449            DO jj = 1, jpj 
    436450               DO ji = 1, jpi 
    437                   zt  = pts  (ji,jj,jk,jp_tem) - 10._wp 
     451                  zt  = pts  (ji,jj,jk,jp_tem) - ST0 
    438452                  zs  = pts  (ji,jj,jk,jp_sal) - 35._wp 
    439453                  zh  = pdep (ji,jj,jk) 
    440454                  ztm = tmask(ji,jj,jk) 
    441455                  !                                                     ! potential density referenced at the surface 
    442                   zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt ) * zt   & 
    443                      &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs ) * zs   & 
    444                      &  - rn_nu * zt * zs 
     456                  zn =  - ( SA0 + 0.5_wp*SCB * zt ) * zt + SB0 * zs 
    445457                  prhop(ji,jj,jk) = ( rau0 + zn ) * ztm 
    446458                  !                                                     ! density anomaly (masked) 
    447                   zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh 
     459                  zn = zn - STH * zh * zt 
    448460                  prd(ji,jj,jk) = zn * r1_rau0 * ztm 
    449461                  ! 
    … …  
    466478      !! 
    467479      !! ** Purpose :   Compute the in situ density (ratio rho/rau0) from 
    468       !!      potential temperature and salinity using an equation of state 
    469       !!      defined through the namelist parameter nn_eos. * 2D field case 
     480      !!      temperature and salinity using an equation of state 
     481      !!      selected in the nameos namelist. * 2D field case 
    470482      !! 
    471483      !! ** Action  : - prd , the in situ density (no units) (unmasked) 
    472       !! 
    473484      !!---------------------------------------------------------------------- 
    474485      REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in   ) ::   pts   ! 1 : potential temperature  [Celcius] 
    … …  
    486497      prd(:,:) = 0._wp 
    487498      ! 
    488       SELECT CASE( nn_eos ) 
    489       ! 
    490       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     499      SELECT CASE( neos ) 
     500      ! 
     501      CASE( np_teos10 , np_eos80 )               !==  polynomial TEOS-10 or EOS-80 ==! 
    491502         ! 
    492503         DO jj = 1, jpjm1 
    … …  
    527538         CALL lbc_lnk( prd, 'T', 1. )                    ! Lateral boundary conditions 
    528539         ! 
    529       CASE( 1 )                !==  simplified EOS  ==! 
     540      CASE( np_seos , np_leos )                !==  simplified or linear EOS  ==! 
    530541         ! 
    531542         DO jj = 1, jpjm1 
    532543            DO ji = 1, fs_jpim1   ! vector opt. 
    533544               ! 
    534                zt    = pts  (ji,jj,jp_tem)  - 10._wp 
     545               zt    = pts  (ji,jj,jp_tem)  - ST0 
    535546               zs    = pts  (ji,jj,jp_sal)  - 35._wp 
    536547               zh    = pdep (ji,jj)                         ! depth at the partial step level 
    537548               ! 
    538                zn =  - rn_a0 * ( 1._wp + 0.5_wp*rn_lambda1*zt + rn_mu1*zh ) * zt   & 
    539                   &  + rn_b0 * ( 1._wp - 0.5_wp*rn_lambda2*zs - rn_mu2*zh ) * zs   & 
    540                   &  - rn_nu * zt * zs 
    541                   ! 
     549               zn =  - ( SA0 + 0.5_wp*SCB * zt + STH * zh ) * zt + SB0 * zs 
     550               ! 
    542551               prd(ji,jj) = zn * r1_rau0               ! unmasked in situ density anomaly 
    543552               ! 
    … …  
    576585      IF( nn_timing == 1 )   CALL timing_start('rab_3d') 
    577586      ! 
    578       SELECT CASE ( nn_eos ) 
    579       ! 
    580       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     587      SELECT CASE ( neos ) 
     588      ! 
     589      CASE( np_teos10 , np_eos80 )               !==  polynomial TEOS-10 or EOS-80 ==! 
    581590         ! 
    582591         DO jk = 1, jpkm1 
    … …  
    635644         END DO 
    636645         ! 
    637       CASE( 1 )                  !==  simplified EOS  ==! 
     646      CASE( np_seos , np_leos )                  !==  simplified or linear EOS  ==! 
    638647         ! 
    639648         DO jk = 1, jpkm1 
    640649            DO jj = 1, jpj 
    641650               DO ji = 1, jpi 
    642                   zt  = pts (ji,jj,jk,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     651                  zt  = pts (ji,jj,jk,jp_tem) - ST0      ! pot. temperature anomaly (t-T0) 
    643652                  zs  = pts (ji,jj,jk,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    644653                  zh  = gdept_n(ji,jj,jk)                ! depth in meters at t-point 
    645654                  ztm = tmask(ji,jj,jk)                  ! land/sea bottom mask = surf. mask 
    646655                  ! 
    647                   zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    648                   pab(ji,jj,jk,jp_tem) = zn * r1_rau0 * ztm   ! alpha 
    649                   ! 
    650                   zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    651                   pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * ztm   ! beta 
     656                  pab(ji,jj,jk,jp_tem) = ( SA0 + SCB * zt + STH * zh ) * r1_rau0 * ztm    ! alpha 
     657                  ! 
     658                  pab(ji,jj,jk,jp_sal) =   SB0                         * r1_rau0 * ztm    ! beta 
    652659                  ! 
    653660               END DO 
    … …  
    657664      CASE DEFAULT 
    658665         IF(lwp) WRITE(numout,cform_err) 
    659          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     666         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos 
    660667         nstop = nstop + 1 
    661668         ! 
    … …  
    668675      ! 
    669676   END SUBROUTINE rab_3d 
     677 
    670678 
    671679   SUBROUTINE rab_2d( pts, pdep, pab ) 
    … …  
    690698      pab(:,:,:) = 0._wp 
    691699      ! 
    692       SELECT CASE ( nn_eos ) 
    693       ! 
    694       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     700      SELECT CASE ( neos ) 
     701      ! 
     702      CASE( np_teos10 , np_eos80 )               !==  polynomial TEOS-10 or EOS-80 ==! 
    695703         ! 
    696704         DO jj = 1, jpjm1 
    … …  
    750758         CALL lbc_lnk( pab(:,:,jp_sal), 'T', 1. )                     
    751759         ! 
    752       CASE( 1 )                  !==  simplified EOS  ==! 
     760      CASE( np_seos , np_leos )                  !==  simplified or linear EOS  ==! 
    753761         ! 
    754762         DO jj = 1, jpjm1 
    755763            DO ji = 1, fs_jpim1   ! vector opt. 
    756764               ! 
    757                zt    = pts  (ji,jj,jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     765               zt    = pts  (ji,jj,jp_tem) - ST0      ! pot. temperature anomaly (t-T0) 
    758766               zs    = pts  (ji,jj,jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    759767               zh    = pdep (ji,jj)                   ! depth at the partial step level 
    760768               ! 
    761                zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    762                pab(ji,jj,jp_tem) = zn * r1_rau0   ! alpha 
    763                ! 
    764                zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    765                pab(ji,jj,jp_sal) = zn * r1_rau0   ! beta 
     769               pab(ji,jj,jp_tem) = ( SA0 + SCB * zt + STH * zh ) * r1_rau0    ! alpha 
     770               ! 
     771               pab(ji,jj,jp_sal) =   SB0                         * r1_rau0    ! beta 
    766772               ! 
    767773            END DO 
    … …  
    773779      CASE DEFAULT 
    774780         IF(lwp) WRITE(numout,cform_err) 
    775          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     781         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos 
    776782         nstop = nstop + 1 
    777783         ! 
    … …  
    806812      pab(:) = 0._wp 
    807813      ! 
    808       SELECT CASE ( nn_eos ) 
    809       ! 
    810       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     814      SELECT CASE ( neos ) 
     815      ! 
     816      CASE( np_teos10 , np_eos80 )        !==  polynomial TEOS-10 or EOS-80 ==! 
    811817         ! 
    812818         ! 
    … …  
    858864         ! 
    859865         ! 
    860          ! 
    861       CASE( 1 )                  !==  simplified EOS  ==! 
    862          ! 
    863          zt    = pts(jp_tem) - 10._wp   ! pot. temperature anomaly (t-T0) 
     866      CASE( np_seos , np_leos )           !==  simplified or linear EOS  ==! 
     867         ! 
     868         zt    = pts(jp_tem) - ST0      ! pot. temperature anomaly (t-T0) 
    864869         zs    = pts(jp_sal) - 35._wp   ! abs. salinity anomaly (s-S0) 
    865          zh    = pdep                    ! depth at the partial step level 
    866          ! 
    867          zn  = rn_a0 * ( 1._wp + rn_lambda1*zt + rn_mu1*zh ) + rn_nu*zs 
    868          pab(jp_tem) = zn * r1_rau0   ! alpha 
    869          ! 
    870          zn  = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt 
    871          pab(jp_sal) = zn * r1_rau0   ! beta 
     870         zh    = pdep                   ! depth at the partial step level 
     871         ! 
     872         pab(jp_tem) = ( SA0 + SCB * zt + STH * zh ) * r1_rau0    ! alpha 
     873         ! 
     874         pab(jp_sal) =   SB0                         * r1_rau0    ! beta 
    872875         ! 
    873876      CASE DEFAULT 
    874877         IF(lwp) WRITE(numout,cform_err) 
    875          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     878         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos 
    876879         nstop = nstop + 1 
    877880         ! 
    … …  
    885888   SUBROUTINE bn2( pts, pab, pn2 ) 
    886889      !!---------------------------------------------------------------------- 
    887       !!                  ***  ROUTINE bn2  *** 
     890      !!                        ***  ROUTINE bn2  *** 
    888891      !! 
    889892      !! ** Purpose :   Compute the local Brunt-Vaisala frequency at the  
    890893      !!                time-step of the input arguments 
    891894      !! 
    892       !! ** Method  :   pn2 = grav * (alpha dk[T] + beta dk[S] ) / e3w 
     895      !! ** Method  :   pn2 = grav * (a*dk[T] + b*dk[S] ) / e3w 
    893896      !!      where alpha and beta are given in pab, and computed on T-points. 
    894897      !!      N.B. N^2 is set one for all to zero at jk=1 in istate module. 
    895898      !! 
    896899      !! ** Action  :   pn2 : square of the brunt-vaisala frequency at w-point  
    897       !! 
    898900      !!---------------------------------------------------------------------- 
    899901      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::  pts   ! pot. temperature and salinity   [Celcius,psu] 
    … …  
    9991001      !!       checkvalue: tf=-2.588567 Celsius for s=40psu, z=500m 
    10001002      !! 
     1003      !!       Note1: ptf is the IN SITU freezing temperature. It is equal to the potential 
     1004      !!              one when pdep=0 (or pdep is not present). 
     1005      !!              Potential freezing point is what is needed by sea-ice model 
     1006      !!       Note2: This formulation needs a salinity given in Practical Salinity Units (PSU) 
     1007      !!              With other EOS than EOS-80, the salinity is multiplied by a factor  
     1008      !!              of 35/35.16504 to convert salinity from Absolute to Practical. 
     1009      !!              This approximation leads to a ~0.003.degrees rms difference with the 
     1010      !!              exact value of the freezing point.   
     1011      !! 
    10011012      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10021013      !!---------------------------------------------------------------------- 
    … …  
    10091020      !!---------------------------------------------------------------------- 
    10101021      ! 
    1011       SELECT CASE ( nn_eos ) 
    1012       ! 
    1013       CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    1014          ! 
    1015          DO jj = 1, jpj 
    1016             DO ji = 1, jpi 
    1017                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
    1018                ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    1019                   &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    1020             END DO 
    1021          END DO 
    1022          ptf(:,:) = ptf(:,:) * psal(:,:) 
    1023          ! 
    1024          IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 
    1025          ! 
    1026       CASE ( 0 )                     !==  PT,SP (UNESCO formulation)  ==! 
    1027          ! 
    1028          ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) )   & 
    1029             &                     - 2.154996e-4_wp *       psal(:,:)   ) * psal(:,:) 
    1030             ! 
    1031          IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 
    1032          ! 
    1033       CASE DEFAULT 
    1034          IF(lwp) WRITE(numout,cform_err) 
    1035          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
    1036          nstop = nstop + 1 
    1037          ! 
    1038       END SELECT       
     1022      ptf(:,:) = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal(:,:) * rSA2SP )   & 
     1023         &                     - 2.154996e-4_wp *       psal(:,:) * rSA2SP   ) * psal(:,:) * rSA2SP 
     1024         ! 
     1025      IF( PRESENT( pdep ) )   ptf(:,:) = ptf(:,:) - 7.53e-4 * pdep(:,:) 
    10391026      ! 
    10401027  END SUBROUTINE eos_fzp_2d 
     1028 
    10411029 
    10421030  SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
    … …  
    10591047      !!---------------------------------------------------------------------- 
    10601048      ! 
    1061       SELECT CASE ( nn_eos ) 
    1062       ! 
    1063       CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    1064          ! 
    1065          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
    1066          ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    1067                   &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
    1068          ptf = ptf * psal 
    1069          ! 
    1070          IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep 
    1071          ! 
    1072       CASE ( 0 )                     !==  PT,SP (UNESCO formulation)  ==! 
    1073          ! 
    1074          ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal )   & 
    1075             &                - 2.154996e-4_wp *       psal   ) * psal 
    1076             ! 
    1077          IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep 
    1078          ! 
    1079       CASE DEFAULT 
    1080          IF(lwp) WRITE(numout,cform_err) 
    1081          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
    1082          nstop = nstop + 1 
    1083          ! 
    1084       END SELECT 
     1049      ptf = ( - 0.0575_wp + 1.710523e-3_wp * SQRT( psal * rSA2SP )   & 
     1050         &                - 2.154996e-4_wp *       psal * rSA2SP   ) * psal * rSA2SP 
     1051         ! 
     1052      IF( PRESENT( pdep ) )   ptf = ptf - 7.53e-4 * pdep 
    10851053      ! 
    10861054   END SUBROUTINE eos_fzp_0d 
    … …  
    11091077      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in   ) ::   pts     ! pot. temperature & salinity 
    11101078      REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(  out) ::   pab_pe  ! alpha_pe and beta_pe 
    1111       REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   ppen     ! potential energy anomaly 
     1079      REAL(wp), DIMENSION(jpi,jpj,jpk)     , INTENT(  out) ::   ppen    ! potential energy anomaly 
    11121080      ! 
    11131081      INTEGER  ::   ji, jj, jk                ! dummy loop indices 
    … …  
    11181086      IF( nn_timing == 1 )   CALL timing_start('eos_pen') 
    11191087      ! 
    1120       SELECT CASE ( nn_eos ) 
    1121       ! 
    1122       CASE( -1, 0 )                !==  polynomial TEOS-10 / EOS-80 ==! 
     1088      SELECT CASE ( neos ) 
     1089      ! 
     1090      CASE( np_teos10 , np_eos80 )               !==  polynomial TEOS-10 or EOS-80 ==! 
    11231091         ! 
    11241092         DO jk = 1, jpkm1 
    … …  
    11831151         END DO 
    11841152         ! 
    1185       CASE( 1 )                !==  Vallis (2006) simplified EOS  ==! 
     1153      CASE( np_seos , np_leos )                !==  simplified or linear EOS  ==! 
    11861154         ! 
    11871155         DO jk = 1, jpkm1 
    11881156            DO jj = 1, jpj 
    11891157               DO ji = 1, jpi 
    1190                   zt  = pts(ji,jj,jk,jp_tem) - 10._wp  ! temperature anomaly (t-T0) 
    1191                   zs = pts (ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
     1158                  zt  = pts(ji,jj,jk,jp_tem) - ST0     ! temperature anomaly (t-T0) 
     1159                  zs  = pts(ji,jj,jk,jp_sal) - 35._wp  ! abs. salinity anomaly (s-S0) 
    11921160                  zh  = gdept_n(ji,jj,jk)              ! depth in meters  at t-point 
    11931161                  ztm = tmask(ji,jj,jk)                ! tmask 
    11941162                  zn  = 0.5_wp * zh * r1_rau0 * ztm 
    11951163                  !                                    ! Potential Energy 
    1196                   ppen(ji,jj,jk) = ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zn 
     1164                  ppen(ji,jj,jk) = STH * zt * zn 
    11971165                  !                                    ! alphaPE 
    1198                   pab_pe(ji,jj,jk,jp_tem) = - rn_a0 * rn_mu1 * zn 
    1199                   pab_pe(ji,jj,jk,jp_sal) =   rn_b0 * rn_mu2 * zn 
     1166                  pab_pe(ji,jj,jk,jp_tem) = - STH * zn 
     1167                  pab_pe(ji,jj,jk,jp_sal) =   0._wp 
    12001168                  ! 
    12011169               END DO 
    … …  
    12051173      CASE DEFAULT 
    12061174         IF(lwp) WRITE(numout,cform_err) 
    1207          IF(lwp) WRITE(numout,*) '          bad flag value for nn_eos = ', nn_eos 
     1175         IF(lwp) WRITE(numout,*) '          bad flag value for neos = ', neos 
    12081176         nstop = nstop + 1 
    12091177         ! 
    … …  
    12231191      !! ** Method  :   Read the namelist nameos and control the parameters 
    12241192      !!---------------------------------------------------------------------- 
    1225       INTEGER  ::   ios   ! local integer 
    1226       !! 
    1227       NAMELIST/nameos/ nn_eos, ln_useCT, rn_a0, rn_b0, rn_lambda1, rn_mu1,   & 
    1228          &                                             rn_lambda2, rn_mu2, rn_nu 
     1193      INTEGER  ::   ios, ioptio   ! local integer 
     1194      !! 
     1195      NAMELIST/nameos/ ln_TEOS10, ln_EOS80, ln_SEOS, ln_LEOS,   &    ! EOS choice 
     1196         &             rn_a0, rn_b0, rn_cb, rn_t0, rn_th,       &    ! S-EOS parameters 
     1197         &             rn_al, rn_bl                                  ! L-EOS   -   - 
    12291198      !!---------------------------------------------------------------------- 
    12301199      ! 
    … …  
    12381207      IF(lwm) WRITE( numond, nameos ) 
    12391208      ! 
    1240       rau0        = 1026._wp                 !: volumic mass of reference     [kg/m3] 
    1241       rcp         = 3991.86795711963_wp      !: heat capacity     [J/K] 
     1209      rau0 = 1026._wp                 !: density of reference   [kg/m3] 
     1210      rcp  = 3991.86795711963_wp      !: heat capacity          [J/K] 
    12421211      ! 
    12431212      IF(lwp) THEN                ! Control print 
    … …  
    12451214         WRITE(numout,*) 'eos_init : equation of state' 
    12461215         WRITE(numout,*) '~~~~~~~~' 
    1247          WRITE(numout,*) '          Namelist nameos : set eos parameters' 
    1248          WRITE(numout,*) '             flag for eq. of state and N^2  nn_eos   = ', nn_eos 
    1249          IF( ln_useCT )   THEN 
    1250             WRITE(numout,*) '             model uses Conservative Temperature' 
    1251             WRITE(numout,*) '             Important: model must be initialized with CT and SA fields' 
    1252          ELSE 
    1253             WRITE(numout,*) '             model does not use Conservative Temperature' 
    1254          ENDIF 
     1216         WRITE(numout,*) '   Namelist nameos : Chosen the Equation Of Seawater (EOS)' 
     1217         WRITE(numout,*) '      TEOS-10 : rho(Conservative Temperature, Absolute  Salinity, depth)   ln_TEOS10 = ', ln_TEOS10 
     1218         WRITE(numout,*) '      EOS-80  : rho(Potential    Temperature, Practical Salinity, depth)   ln_EOS80  = ', ln_EOS80 
     1219         WRITE(numout,*) '      S-EOS   : rho(Conservative Temperature, Absolute  Salinity, depth)   ln_SEOS   = ', ln_SEOS 
     1220         WRITE(numout,*) '      L-EOS   : rho(Conservative Temperature, Absolute  Salinity       )   ln_LEOS   = ', ln_LEOS 
    12551221      ENDIF 
    1256       ! 
    1257       SELECT CASE( nn_eos )         ! check option 
    1258       ! 
    1259       CASE( -1 )                       !==  polynomial TEOS-10  ==! 
     1222 
     1223      ! Check options for equation of state & set neos based on logical flags 
     1224      ioptio = 0 
     1225      IF( ln_TEOS10 ) THEN   ;   ioptio = ioptio+1   ;   neos = np_teos10   ;   ENDIF 
     1226      IF( ln_EOS80  ) THEN   ;   ioptio = ioptio+1   ;   neos = np_eos80    ;   ENDIF 
     1227      IF( ln_SEOS   ) THEN   ;   ioptio = ioptio+1   ;   neos = np_seos     ;   ENDIF 
     1228      IF( ln_LEOS   ) THEN   ;   ioptio = ioptio+1   ;   neos = np_leos     ;   ENDIF 
     1229      IF( ioptio /= 1 )   CALL ctl_stop("Exactly one equation of state option must be selected") 
     1230      ! 
     1231      SELECT CASE( neos )         ! check option 
     1232      ! 
     1233      CASE( np_teos10 )                       !==  polynomial TEOS-10  ==! 
    12601234         IF(lwp) WRITE(numout,*) 
    12611235         IF(lwp) WRITE(numout,*) '          use of TEOS-10 equation of state (cons. temp. and abs. salinity)' 
     1236         ! 
     1237         l_useCT = .TRUE.                          ! model temperature is Conservative temperature  
     1238         rSA2SP  = 35._wp / 35.16504_wp            ! model salinity is Absolute Salinity (= conversion from SA to SP) 
    12621239         ! 
    12631240         rdeltaS = 32._wp 
    … …  
    14461423         BPE002 = 1.7269476440e-04_wp 
    14471424         ! 
    1448       CASE( 0 )                        !==  polynomial EOS-80 formulation  ==! 
     1425      CASE( np_eos80 )                        !==  polynomial EOS-80 formulation  ==! 
    14491426         ! 
    14501427         IF(lwp) WRITE(numout,*) 
    14511428         IF(lwp) WRITE(numout,*) '          use of EOS-80 equation of state (pot. temp. and pract. salinity)' 
     1429         ! 
     1430         l_useCT = .FALSE.                         ! model temperature is Potential temperature 
     1431         rSA2SP  = 1._wp                           ! model salinity is SP (Practical Salinity) ==>> rSA2SP=1 
    14521432         ! 
    14531433         rdeltaS = 20._wp 
    … …  
    16361616         BPE002 = 5.3661089288e-04_wp 
    16371617         ! 
    1638       CASE( 1 )                        !==  Simplified EOS     ==! 
     1618      CASE( np_seos )                        !==  Simplified EOS  ==! 
    16391619         IF(lwp) THEN 
    16401620            WRITE(numout,*) 
    1641             WRITE(numout,*) '          use of simplified eos:    rhd(dT=T-10,dS=S-35,Z) = ' 
    1642             WRITE(numout,*) '             [-a0*(1+lambda1/2*dT+mu1*Z)*dT + b0*(1+lambda2/2*dT+mu2*Z)*dS - nu*dT*dS]/rau0' 
     1621            WRITE(numout,*) '          use of simplified eos (S-EOS):     ' 
     1622            WRITE(numout,*) '   rhd(dT=CT-T0,dS=SA-35,Z) = [ - (a0 + cb/2*dT + th*Z )*dT + b0*dS ] / rau0' 
     1623            WRITE(numout,*) '          with' 
     1624            WRITE(numout,*) '             linear thermal expansion coef.   a0 = rn_a0 = ', rn_a0 
     1625            WRITE(numout,*) '             haline  contraction coef.        b0 = rn_b0 = ', rn_b0 
     1626            WRITE(numout,*) '             cabbeling coef.                  cb = rn_cb = ', rn_cb 
     1627            WRITE(numout,*) '             reference temperature coef.      T0 = rn_t0 = ', rn_t0 
     1628            WRITE(numout,*) '             thermobaric coef.                th = rn_th = ', rn_th 
    16431629            WRITE(numout,*) 
    1644             WRITE(numout,*) '             thermal exp. coef.    rn_a0      = ', rn_a0 
    1645             WRITE(numout,*) '             saline  cont. coef.   rn_b0      = ', rn_b0 
    1646             WRITE(numout,*) '             cabbeling coef.       rn_lambda1 = ', rn_lambda1 
    1647             WRITE(numout,*) '             cabbeling coef.       rn_lambda2 = ', rn_lambda2 
    1648             WRITE(numout,*) '             thermobar. coef.      rn_mu1     = ', rn_mu1 
    1649             WRITE(numout,*) '             thermobar. coef.      rn_mu2     = ', rn_mu2 
    1650             WRITE(numout,*) '             2nd cabbel. coef.     rn_nu      = ', rn_nu 
    1651             WRITE(numout,*) '               Caution: rn_beta0=0 incompatible with ddm parameterization ' 
    16521630         ENDIF 
    1653          ! 
    1654       CASE DEFAULT                     !==  ERROR in nn_eos  ==! 
    1655          WRITE(ctmp1,*) '          bad flag value for nn_eos = ', nn_eos 
     1631         IF( rn_b0 == 0._wp )   CALL ctl_warn('eos_init: rn_b0=0 incompatible with ddm parameterization ') 
     1632         IF( rn_a0 == 0._wp .AND. rn_cb == 0._wp )   CALL ctl_stop('eos_init:  S-EOS need non zero a0 or cb') 
     1633         ! 
     1634         l_useCT = .TRUE.                 ! Use Conservative Temperature  
     1635         rSA2SP  = 35._wp / 35.16504_wp   ! model salinity is Absolute Salinity (= conversion from SA to SP) 
     1636         ! 
     1637         SA0 = rn_a0 
     1638         SB0 = rn_b0 
     1639         SCB = rn_cb 
     1640         ST0 = rn_t0 
     1641         STH = rn_th 
     1642         ! 
     1643      CASE( np_leos )                        !==  Linear EOS     ==! 
     1644         IF(lwp) THEN 
     1645            WRITE(numout,*) 
     1646            WRITE(numout,*) '          use of linear eos (L-EOS):    ' 
     1647            WRITE(numout,*) '   rhd(dT=CT-10,dS=SA-35) = [ - al*dT + bl*dS ] / rau0' 
     1648            WRITE(numout,*) '          with' 
     1649            WRITE(numout,*) '             thermal expansion   coef.   al = rn_al = ', rn_al 
     1650            WRITE(numout,*) '             haline  contraction coef.   bl = rn_bl = ', rn_bl 
     1651            WRITE(numout,*) 
     1652         ENDIF 
     1653         IF( rn_bl == 0._wp )   CALL ctl_warn('eos_init: rn_bl=0 incompatible with ddm parameterization ') 
     1654         ! 
     1655         l_useCT = .TRUE.                 ! Use Conservative Temperature 
     1656         rSA2SP  = 35._wp / 35.16504_wp   ! model salinity is Absolute Salinity (= conversion from SA to SP) 
     1657         ! 
     1658         SA0 =  rn_al 
     1659         SB0 =  rn_bl 
     1660         SCB =  0._wp 
     1661         ST0 = 10._wp 
     1662         STH =  0._wp 
     1663         ! 
     1664      CASE DEFAULT                     !==  ERROR in neos  ==! 
     1665         WRITE(ctmp1,*) '          bad flag value for neos = ', neos, '. You should never see this error' 
    16561666         CALL ctl_stop( ctmp1 ) 
    16571667         ! 
    … …  
    16631673      r1_rau0_rcp = 1._wp / rau0_rcp  
    16641674      ! 
     1675      IF(lwp) THEN 
     1676         IF( l_useCT )   THEN 
     1677            WRITE(numout,*) '          The ocean model uses Conservative Temperature and Absolute Salinity' 
     1678            WRITE(numout,*) '          Important: model initialization must be with CT and SA fields' 
     1679         ELSE 
     1680            WRITE(numout,*) '          model use Potential Temperature and Practical salinity' 
     1681         ENDIF 
     1682      ENDIF 
     1683      ! 
    16651684      IF(lwp) WRITE(numout,*) 
    1666       IF(lwp) WRITE(numout,*) '          volumic mass of reference           rau0 = ', rau0   , ' kg/m^3' 
    1667       IF(lwp) WRITE(numout,*) '          1. / rau0                        r1_rau0 = ', r1_rau0, ' m^3/kg' 
    1668       IF(lwp) WRITE(numout,*) '          ocean specific heat                 rcp   = ', rcp    , ' J/Kelvin' 
    1669       IF(lwp) WRITE(numout,*) '          rau0 * rcp                       rau0_rcp = ', rau0_rcp 
    1670       IF(lwp) WRITE(numout,*) '          1. / ( rau0 * rcp )           r1_rau0_rcp = ', r1_rau0_rcp 
     1685      IF(lwp) WRITE(numout,*) '          density of reference               rau0 = ', rau0   , ' kg/m^3' 
     1686      IF(lwp) WRITE(numout,*) '          1. / rau0                       r1_rau0 = ', r1_rau0, ' m^3/kg' 
     1687      IF(lwp) WRITE(numout,*) '          ocean specific heat                 rcp = ', rcp    , ' J/Kelvin' 
     1688      IF(lwp) WRITE(numout,*) '          rau0 * rcp                     rau0_rcp = ', rau0_rcp 
     1689      IF(lwp) WRITE(numout,*) '          1. / ( rau0 * rcp )         r1_rau0_rcp = ', r1_rau0_rcp 
    16711690      ! 
    16721691   END SUBROUTINE eos_init 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRA/trabbl.F90

    r6140 r6851  
    122122         ! 
    123123         CALL tra_bbl_dif( tsb, tsa, jpts ) 
    124          IF( ln_ctl )  & 
    125          CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask, & 
    126             &          tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
     124         IF( ln_ctl )   CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf  - Ta: ', mask1=tmask,   & 
     125            &                         tab3d_2=tsa(:,:,:,jp_sal), clinfo2=           ' Sa: ', mask2=tmask, clinfo3='tra' ) 
    127126         ! lateral boundary conditions ; just need for outputs 
    128127         CALL lbc_lnk( ahu_bbl, 'U', 1. )     ;     CALL lbc_lnk( ahv_bbl, 'V', 1. ) 
    … …  
    255254         DO jj = 1, jpjm1 
    256255            DO ji = 1, jpim1            ! CAUTION start from i=1 to update i=2 when cyclic east-west 
    257                IF( utr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero i-direction bbl advection 
     256               IF( utr_bbl(ji,jj) /= 0._wp ) THEN            ! non-zero i-direction bbl advection 
    258257                  ! down-slope i/k-indices (deep)      &   up-slope i/k indices (shelf) 
    259258                  iid  = ji + MAX( 0, mgrhu(ji,jj) )   ;   iis  = ji + 1 - MAX( 0, mgrhu(ji,jj) ) 
    … …  
    277276               ENDIF 
    278277               ! 
    279                IF( vtr_bbl(ji,jj) /= 0.e0 ) THEN            ! non-zero j-direction bbl advection 
     278               IF( vtr_bbl(ji,jj) /= 0._wp ) THEN            ! non-zero j-direction bbl advection 
    280279                  ! down-slope j/k-indices (deep)        &   up-slope j/k indices (shelf) 
    281280                  ijd  = jj + MAX( 0, mgrhv(ji,jj) )     ;   ijs  = jj + 1 - MAX( 0, mgrhv(ji,jj) ) 
    … …  
    452451                  zgdrho = 0.5 * (  za * ( zts(iid,jj,jp_tem) - zts(iis,jj,jp_tem) )    & 
    453452                     &            - zb * ( zts(iid,jj,jp_sal) - zts(iis,jj,jp_sal) )  ) * umask(ji,jj,1) 
    454                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     453                  zgdrho = MAX( 0._wp, zgdrho )                               ! only if shelf is denser than deep 
    455454                  ! 
    456455                  !                                                          ! bbl transport (down-slope direction) 
    … …  
    470469                  zgdrho = 0.5 * (  za * ( zts(ji,ijd,jp_tem) - zts(ji,ijs,jp_tem) )    & 
    471470                     &            - zb * ( zts(ji,ijd,jp_sal) - zts(ji,ijs,jp_sal) )  ) * vmask(ji,jj,1) 
    472                   zgdrho = MAX( 0.e0, zgdrho )                               ! only if shelf is denser than deep 
     471                  zgdrho = MAX( 0._wp, zgdrho )                               ! only if shelf is denser than deep 
    473472                  ! 
    474473                  !                                                          ! bbl transport (down-slope direction) 
    … …  
    549548      DO jj = 1, jpjm1 
    550549         DO ji = 1, jpim1 
    551             mgrhu(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    552             mgrhv(ji,jj) = INT(  SIGN( 1.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     550            mgrhu(ji,jj) = INT(  SIGN( 1._wp, gdept_0(ji+1,jj,mbkt(ji+1,jj)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
     551            mgrhv(ji,jj) = INT(  SIGN( 1._wp, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) )  ) 
    553552         END DO 
    554553      END DO 
    … …  
    573572            ij0 = 102   ;   ij1 = 102              ! Gibraltar enhancement of BBL 
    574573            ii0 = 139   ;   ii1 = 140 
    575             ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    576             ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     574            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4._wp*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     575            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4._wp*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    577576            ! 
    578577            ij0 =  88   ;   ij1 =  88              ! Red Sea enhancement of BBL 
    579578            ii0 = 161   ;   ii1 = 162 
    580             ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    581             ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     579            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10._wp*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     580            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) = 10._wp*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    582581            ! 
    583582         CASE ( 4 )                          ! ORCA_R4 
    584583            ij0 =  52   ;   ij1 =  52              ! Gibraltar enhancement of BBL 
    585584            ii0 =  70   ;   ii1 =  71 
    586             ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    587             ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4.e0*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     585            ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4._wp*ahu_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
     586            ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) =  4._wp*ahv_bbl_0(mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1)) 
    588587         END SELECT 
    589588         ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

    r6140 r6851  
    178178      IF( ln_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) )                                    & 
    179179           &            CALL ctl_stop( 'eddy induced velocity on tracers requires iso-neutral laplacian diffusion' ) 
     180      IF( ln_isfcav .AND. ln_traldf_triad ) & 
     181           &            CALL ctl_stop( ' ice shelf cavity and traldf_triad not tested' ) 
    180182           ! 
    181183      IF(  nldf == np_lap_i .OR. nldf == np_lap_it .OR. & 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r6347 r6851  
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    1212   !!            3.6  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
    13    !!             -   !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
    14    !!            3.7  !  2016-01  (G. Madec, A. Coward)  remove optimisation for fix volume  
     13   !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
     14   !!            3.7  !  2015-11  (G. Madec, A. Coward)  remove optimisation for fix volume  
    1515   !!---------------------------------------------------------------------- 
    1616 
    … …  
    5656   INTEGER , PUBLIC ::   nksr         !: levels below which the light cannot penetrate (depth larger than 391 m) 
    5757  
    58    INTEGER, PARAMETER ::   np_RGB    = 1   ! R-G-B     light penetration with constant Chlorophyll 
    59    INTEGER, PARAMETER ::   np_2BD    = 2   ! 2 bands   light penetration 
    60    INTEGER, PARAMETER ::   np_BIO    = 3   ! bio-model light penetration 
     58   INTEGER, PARAMETER ::   np_RGB  = 1   ! R-G-B     light penetration with constant Chlorophyll 
     59   INTEGER, PARAMETER ::   np_RGBc = 2   ! R-G-B     light penetration with Chlorophyll data 
     60   INTEGER, PARAMETER ::   np_2BD  = 3   ! 2 bands   light penetration 
     61   INTEGER, PARAMETER ::   np_BIO  = 4   ! bio-model light penetration 
    6162   ! 
    6263   INTEGER  ::   nqsr    ! user choice of the type of light penetration 
    6364   REAL(wp) ::   xsi0r   ! inverse of rn_si0 
    6465   REAL(wp) ::   xsi1r   ! inverse of rn_si1 
    65     
    66    REAL(wp) ::   rChl_0 = 0.05_wp   ! value of Chlorophyll used in case of constant Chlorophyll 
    6766   ! 
    6867   REAL(wp) , DIMENSION(3,61)           ::   rkrgb    ! tabulated attenuation coefficients for RGB absorption 
    69    TYPE(FLD), DIMENSION(:), ALLOCATABLE ::   sf_chl   ! structure of input Chl (file informations, fields read) 
     68   TYPE(FLD), ALLOCATABLE, DIMENSION(:) ::   sf_chl   ! structure of input Chl (file informations, fields read) 
    7069 
    7170   !! * Substitutions 
    … …  
    110109      REAL(wp) ::   zchl, zcoef, z1_2        ! local scalars 
    111110      REAL(wp) ::   zc0 , zc1 , zc2 , zc3    !    -         - 
     111      REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    112112      REAL(wp) ::   zz0 , zz1                !    -         - 
    113       REAL(wp) ::   zCb, zCmax, zze, z1_ze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
     113      REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
    114114      REAL(wp) ::   zlogc, zlogc2, zlogc3  
    115115      REAL(wp), POINTER, DIMENSION(:,:)   :: zekb, zekg, zekr 
    116       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, zchl3d, ztrdt 
    117       REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot 
     116      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
     117      REAL(wp), POINTER, DIMENSION(:,:,:) :: zetot, zchl3d 
    118118      !!---------------------------------------------------------------------- 
    119119      ! 
    … …  
    153153      !                         !--------------------------------! 
    154154      ! 
    155       CASE( np_BIO )                !==  bio-model fluxes  ==! 
     155      CASE( np_BIO )                   !==  bio-model fluxes  ==! 
    156156         ! 
    157157         DO jk = 1, nksr 
    … …  
    159159         END DO 
    160160         ! 
    161       CASE( np_RGB )                !==  R-G-B fluxes  ==! 
     161      CASE( np_RGB , np_RGBc )         !==  R-G-B fluxes  ==! 
    162162         ! 
    163163         CALL wrk_alloc( jpi,jpj,       zekb, zekg, zekr                )  
    164164         CALL wrk_alloc( jpi,jpj,jpk,   ze0, ze1, ze2, ze3, zea, zchl3d )  
    165165         ! 
    166          SELECT CASE( nn_chldta )         ! set 3D chlorophyll field 
    167          ! 
    168          CASE( 0 )                           ! constant  
     166         IF( nqsr == np_RGBc ) THEN          !*  Variable Chlorophyll 
     167            CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
    169168            DO jk = 1, nksr + 1 
    170                zchl3d(:,:,jk) = rChl_0 
    171             END DO 
    172             ! 
    173          CASE( 1 )                           ! surface chlorophyl data spread uniformly on the vertical 
    174             CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
    175             DO jk = 1, nksr + 1                    ! uniform vertical profile 
    176                zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1)  
    177             END DO 
    178             ! 
    179          CASE( 2 )                           ! surface chlorophyl data + Morel and Berthon (1989) profile 
    180             CALL fld_read( kt, 1, sf_chl )         ! Read Chl data and provides it at the current time step 
    181             DO jj = 2, jpjm1                       ! Chl profile = F( surface Chl value) 
    182                DO ji = fs_2, fs_jpim1 
    183                   zchl    = sf_chl(1)%fnow(ji,jj,1) 
    184                   zCtot   =  40.6_wp *  zchl**0.459 
    185                   zze     = 568.2_wp * zCtot**(-0.746) 
    186                   IF( zze > 102. )   zze = 200.0 * zCtot**(-0.293) 
    187                   zlogc   = LOG( zchl ) 
    188 !!gm : instead of this : 
    189                   zlogc2  = zlogc * zlogc 
    190                   zlogc3  = zlogc * zlogc * zlogc 
    191                   zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
    192                   zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
    193                   zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
    194                   zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
    195 !!gm faster & more precise: 
    196 !                  zCb     = 0.768 + zlogc * (  (  0.087 + zlogc * (- 0.179 - zlogc * 0.025 )  ) 
    197 !                  zCmax   = 0.299 + zlogc * (   - 0.289 + zlogc *    0.579  ) 
    198 !                  zpsimax = 0.6   + zlogc * (  (- 0.640 + zlogc * (  0.021 + zlogc * 0.115 )  ) 
    199 !                  zdelpsi = 0.710 + zlogc * (     0.159 + zlogc *    0.021  ) 
    200 !!gm end           
    201                   zCze    = 1.12_wp * (zchl)**0.803  
    202                   z1_ze   = 1._wp / zze 
    203                   DO jk = 1, nksr + 1 
    204                      zpsi = gdept_n(ji,jj,jk) * z1_ze 
     169               DO jj = 2, jpjm1                       ! Separation in R-G-B depending of the surface Chl 
     170                  DO ji = fs_2, fs_jpim1 
     171                     zchl    = sf_chl(1)%fnow(ji,jj,1) 
     172                     zCtot   = 40.6  * zchl**0.459 
     173                     zze     = 568.2 * zCtot**(-0.746) 
     174                     IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
     175                     zpsi    = gdepw_n(ji,jj,jk) / zze 
     176                     ! 
     177                     zlogc   = LOG( zchl ) 
     178                     zlogc2  = zlogc * zlogc 
     179                     zlogc3  = zlogc * zlogc * zlogc 
     180                     zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
     181                     zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
     182                     zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
     183                     zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
     184                     zCze    = 1.12  * (zchl)**0.803  
     185                     ! 
    205186                     zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
    206187                  END DO 
     188                  ! 
    207189               END DO 
    208190            END DO 
    209             ! 
    210          END SELECT 
     191         ELSE                                !* constant chrlorophyll 
     192           DO jk = 1, nksr + 1 
     193              zchl3d(:,:,jk) = 0.05  
     194            ENDDO 
     195         ENDIF 
    211196         ! 
    212197         zcoef  = ( 1. - rn_abs ) / 3._wp    !* surface equi-partition in R-G-B 
    … …  
    221206         END DO 
    222207         ! 
    223          DO jk = 2, nksr+1                   !* interior partition in R-G-B function of 3D Chl 
     208         DO jk = 2, nksr+1                   !* interior equi-partition in R-G-B depending of vertical profile of Chl 
    224209            DO jj = 2, jpjm1 
    225210               DO ji = fs_2, fs_jpim1 
    226                   zchl = MIN( 10._wp , MAX( 0.03_wp , zchl3d(ji,jj,jk) ) ) 
    227                   irgb = NINT( 41._wp + 20._wp * LOG10(zchl) + 1.e-15 ) 
     211                  zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
     212                  irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    228213                  zekb(ji,jj) = rkrgb(1,irgb) 
    229214                  zekg(ji,jj) = rkrgb(2,irgb) 
    … …  
    231216               END DO 
    232217            END DO 
     218 
    233219            DO jj = 2, jpjm1 
    234220               DO ji = fs_2, fs_jpim1 
    … …  
    254240         END DO 
    255241         ! 
    256          CALL wrk_dealloc( jpi,jpj,       zekb, zekg, zekr                )  
     242         CALL wrk_dealloc( jpi,jpj,        zekb, zekg, zekr               )  
    257243         CALL wrk_dealloc( jpi,jpj,jpk,   ze0, ze1, ze2, ze3, zea, zchl3d )  
    258244         ! 
    … …  
    344330      INTEGER  ::   ji, jj, jk                  ! dummy loop indices 
    345331      INTEGER  ::   ios, irgb, ierror, ioptio   ! local integer 
    346 !      REAL(wp) ::   zz0, zc0 , zc1, zcoef      ! local scalars 
    347 !      REAL(wp) ::   zz1, zc2 , zc3, zchl       !   -      - 
    348332      ! 
    349333      CHARACTER(len=100) ::   cn_dir   ! Root directory for location of ssr files 
    … …  
    374358         WRITE(numout,*) '      bio-model            light penetration       ln_qsr_bio = ', ln_qsr_bio 
    375359         WRITE(numout,*) '      light penetration for ice-model (LIM3)       ln_qsr_ice = ', ln_qsr_ice 
    376          WRITE(numout,*) '      RGB : Chl data (=1,2) or cst value (=0)      nn_chldta  = ', nn_chldta 
     360         WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)        nn_chldta  = ', nn_chldta 
    377361         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs     = ', rn_abs 
    378362         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0     = ', rn_si0 
    … …  
    390374      ! 
    391375      IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr = np_RGB  
     376      IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr = np_RGBc 
    392377      IF( ln_qsr_2bd                      )   nqsr = np_2BD 
    393378      IF( ln_qsr_bio                      )   nqsr = np_BIO 
    … …  
    399384      SELECT CASE( nqsr ) 
    400385      !                                
    401       CASE( np_RGB )             !==  Red-Green-Blue light penetration  ==! 
     386      CASE( np_RGB , np_RGBc )         !==  Red-Green-Blue light penetration  ==! 
    402387         !                              
    403388         IF(lwp)   WRITE(numout,*) '   R-G-B   light penetration ' 
    … …  
    409394         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    410395         ! 
    411          SELECT CASE( nn_chldta )         ! set 3D chlorophyll field 
    412          CASE( 0 )                           ! constant 
    413             IF(lwp) WRITE(numout,*) '        constant Chlorophyll set to rChl_0 =', rChl_0  
    414             ! 
    415          CASE( 1 , 2 )                       ! 3D chlorophyl field : read 2D surface data 
    416             ! 
    417             IF(lwp) WRITE(numout,*) '        surface 2D Chlorophyll field read in a file' 
     396         IF( nqsr == np_RGBc ) THEN                ! Chl data : set sf_chl structure 
     397            IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 
    418398            ALLOCATE( sf_chl(1), STAT=ierror ) 
    419399            IF( ierror > 0 ) THEN 
    … …  
    425405            CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init',   & 
    426406               &           'Solar penetration function of read chlorophyll', 'namtra_qsr' ) 
    427             ! 
    428             IF( lwp .AND. nn_chldta == 1 )   WRITE(numout,*) '        profile of chlorophyll : Chl(z) = Chl(z=0)' 
    429             IF( lwp .AND. nn_chldta == 2 )   WRITE(numout,*) '        profile of chlorophyll : Chl(z) = Func[Chl(z=0)]' 
    430             ! 
    431          END SELECT 
    432          ! 
    433       CASE( np_2BD )             !==  2 bands light penetration  ==! 
     407         ENDIF 
     408         IF( nqsr == np_RGB ) THEN                 ! constant Chl 
     409            IF(lwp) WRITE(numout,*) '        Constant Chlorophyll concentration = 0.05' 
     410         ENDIF 
     411         ! 
     412      CASE( np_2BD )                   !==  2 bands light penetration  ==! 
    434413         ! 
    435414         IF(lwp)  WRITE(numout,*) '   2 bands light penetration' 
    … …  
    438417         IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    439418         ! 
    440       CASE( np_BIO )                         !==  BIO light penetration  ==! 
     419      CASE( np_BIO )                   !==  BIO light penetration  ==! 
    441420         ! 
    442421         IF(lwp) WRITE(numout,*) '   bio-model light penetration' 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r6140 r6851  
    207207         END DO   
    208208      ENDIF 
     209 
     210      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     211      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     212 
    209213      ! 
    210214      !---------------------------------------- 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

    r6140 r6851  
    106106         DO jj = 2, jpj 
    107107            DO ji = 2, jpi 
    108                zke(ji,jj,jk) = 0.5_wp * rau0 *( un(ji  ,jj,jk) * putrd(ji  ,jj,jk) * bu(ji  ,jj,jk)  & 
    109                   &                           + un(ji-1,jj,jk) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk)  & 
    110                   &                           + vn(ji,jj  ,jk) * pvtrd(ji,jj  ,jk) * bv(ji,jj  ,jk)  & 
    111                   &                           + vn(ji,jj-1,jk) * pvtrd(ji,jj-1,jk) * bv(ji,jj-1,jk)  ) * r1_bt(ji,jj,jk) 
     108               zke(ji,jj,jk) = 0.25_wp * rau0 * ( un(ji  ,jj,jk) * putrd(ji  ,jj,jk) * bu(ji  ,jj,jk)  & 
     109                  &                              + un(ji-1,jj,jk) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk)  & 
     110                  &                              + vn(ji,jj  ,jk) * pvtrd(ji,jj  ,jk) * bv(ji,jj  ,jk)  & 
     111                  &                              + vn(ji,jj-1,jk) * pvtrd(ji,jj-1,jk) * bv(ji,jj-1,jk)  ) * r1_bt(ji,jj,jk) 
    112112            END DO 
    113113         END DO 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6347 r6851  
    3131   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmld    !: mixing layer depth (turbocline)      [m] 
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlp    !: mixed layer depth  (rho=rho0+zdcrit) [m] 
    33    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: depth of the last T-point inside the mixed layer 
     33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hmlpt   !: depth of the last T-point inside the mixed layer [m] 
    3434 
    3535   REAL(wp), PUBLIC ::   rho_c = 0.01_wp    !: density criterion for mixed layer depth 
    … …  
    7777      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    7878      ! 
    79       INTEGER  ::   ji, jj, jk   ! dummy loop indices 
    80       INTEGER  ::   iikn, iiki, ikt   ! local integer 
    81       REAL(wp) ::   zN2_c        ! local scalar 
     79      INTEGER  ::   ji, jj, jk      ! dummy loop indices 
     80      INTEGER  ::   iikn, iiki, ikt ! local integer 
     81      REAL(wp) ::   zN2_c           ! local scalar 
    8282      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    8383      !!---------------------------------------------------------------------- 
    … …  
    130130      IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
    131131         IF ( iom_use("mldr10_1") ) THEN 
    132             IF( .NOT. ln_isfcav ) CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
    133             IF(       ln_isfcav ) CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     132            IF( ln_isfcav ) THEN   ;   CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
     133            ELSE                   ;   CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
     134            END IF 
    134135         END IF 
    135136         IF ( iom_use("mldkz5") ) THEN 
    136             IF( .NOT. ln_isfcav ) CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
    137             IF(       ln_isfcav ) CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     137            IF( ln_isfcav ) THEN   ;   CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
     138            ELSE                   ;   CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
     139            END IF 
    138140         END IF 
    139141      ENDIF 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90

    r6140 r6851  
    3131   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    3232 
    33    USE eosbn2, ONLY : nn_eos 
     33   USE eosbn2, ONLY : neos 
    3434 
    3535   IMPLICIT NONE 
    … …  
    175175      !  Compute Ekman depth from wind stress forcing. 
    176176      ! ------------------------------------------------------- 
    177       zflageos = ( 0.5 + SIGN( 0.5, nn_eos - 1. ) ) * rau0 
     177!!gm small bug : boussinesq equation of the ocean model 
     178!!gm             therefore rau0 should be used not the potential surface density... 
     179!!gm             ===>>>>   zrhos = rau0  in the epression below, and the rsmall is useless in zustar calculation 
     180      zflageos = ( 0.5 + SIGN( 0.5, neos - 1. ) ) * rau0 
    178181      DO jj = 2, jpjm1 
    179182            DO ji = fs_2, fs_jpim1 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r6347 r6851  
    376376            DO ji = fs_2, fs_jpim1   ! vector opt. 
    377377               zcof   = zfact1 * tmask(ji,jj,jk) 
     378# if defined key_zdftmx_new 
     379               ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
     380               zzd_up = zcof * MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp )   &  ! upper diagonal 
     381                  &          / (  e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk  )  ) 
     382               zzd_lw = zcof * MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp )   &  ! lower diagonal 
     383                  &          / (  e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk  )  ) 
     384# else 
    378385               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    379386                  &          / ( e3t_n(ji,jj,jk  ) * e3w_n(ji,jj,jk  ) ) 
    380387               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    381388                  &          / ( e3t_n(ji,jj,jk-1) * e3w_n(ji,jj,jk  ) ) 
     389# endif 
    382390               !                                   ! shear prod. at w-point weightened by mask 
    383391               zesh2  =  ( z3du(ji-1,jj,jk) + z3du(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

    r6347 r6851  
    698698 
    699699      DO jk = 2, jpkm1              ! complete with the level-dependent part 
    700          emix_tmx(:,:,jk) = zfact(:,:) * (  EXP( ( fsde3w(:,:,jk  ) - zhdep(:,:) ) / hcri_tmx(:,:) )                      & 
    701             &                             - EXP( ( fsde3w(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) )  ) * wmask(:,:,jk)   & 
    702             &                          / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     700         emix_tmx(:,:,jk) = zfact(:,:) * (  EXP( ( gde3w_n(:,:,jk  ) - zhdep(:,:) ) / hcri_tmx(:,:) )                      & 
     701            &                             - EXP( ( gde3w_n(:,:,jk-1) - zhdep(:,:) ) / hcri_tmx(:,:) )  ) * wmask(:,:,jk)   & 
     702            &                          / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) 
    703703      END DO 
    704704 
    … …  
    712712         zfact(:,:) = 0._wp 
    713713         DO jk = 2, jpkm1              ! part independent of the level 
    714             zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     714            zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
    715715         END DO 
    716716 
    … …  
    729729         zfact(:,:) = 0._wp 
    730730         DO jk = 2, jpkm1              ! part independent of the level 
    731             zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
     731            zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) 
    732732         END DO 
    733733 
    … …  
    750750      zfact(:,:) = 0._wp 
    751751      DO jk = 2, jpkm1 
    752          zfact(:,:) = zfact(:,:) + fse3w(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
     752         zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT(  MAX( 0._wp, rn2(:,:,jk) )  ) * wmask(:,:,jk) 
    753753         zwkb(:,:,jk) = zfact(:,:) 
    754754      END DO 
    … …  
    783783      DO jk = 2, jpkm1              ! complete with the level-dependent part 
    784784         emix_tmx(:,:,jk) = emix_tmx(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk)   & 
    785             &                                / ( fsde3w(:,:,jk) - fsde3w(:,:,jk-1) ) 
     785            &                                / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) 
    786786      END DO 
    787787 
    … …  
    827827            DO jj = 1, jpj 
    828828               DO ji = 1, jpi 
    829                   ztpc = ztpc + fse3w(ji,jj,jk) * e1e2t(ji,jj)   & 
     829                  ztpc = ztpc + e3w_n(ji,jj,jk) * e1e2t(ji,jj)   & 
    830830                     &         * MAX( 0._wp, rn2(ji,jj,jk) ) * zav_wave(ji,jj,jk) * wmask(ji,jj,jk) * tmask_i(ji,jj) 
    831831               END DO 
    … …  
    891891         pcmap_tmx(:,:) = 0._wp 
    892892         DO jk = 2, jpkm1 
    893             pcmap_tmx(:,:) = pcmap_tmx(:,:) + fse3w(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 
     893            pcmap_tmx(:,:) = pcmap_tmx(:,:) + e3w_n(:,:,jk) * bflx_tmx(:,:,jk) * wmask(:,:,jk) 
    894894         END DO 
    895895         pcmap_tmx(:,:) = rau0 * pcmap_tmx(:,:) 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6140 r6851  
    112112      ! Update stochastic parameters and random T/S fluctuations 
    113113      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    114                          CALL sto_par( kstp )          ! Stochastic parameters 
     114      IF( ln_sto_eos ) THEN                           ! Stochastic parameterisation 
     115                        CALL sto_par( kstp )                ! Stochastic parameters 
     116                        CALL sto_pts( tsn  )                ! Random T/S fluctuations 
     117      ENDIF 
    115118 
    116119      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    154157      ! 
    155158      IF( l_ldfslp ) THEN                             ! slope of lateral mixing 
    156 !!gm : why this here ???? 
    157          IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    158 !!gm 
    159159                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    160160 
    … …  
    172172         ENDIF 
    173173      ENDIF 
    174       !                                               ! eddy diffusivity coeff. and/or eiv coeff. 
    175       IF( l_ldftra_time .OR. l_ldfeiv_time )   CALL ldf_tra( kstp )  
     174      !                                                                   ! eddy diffusivity coeff. 
     175      IF( l_ldftra_time .OR. l_ldfeiv_time )   CALL ldf_tra( kstp )       !       and/or eiv coeff. 
     176      IF( l_ldfdyn_time                    )   CALL ldf_dyn( kstp )       ! eddy viscosity coeff.  
    176177 
    177178      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    182183      IF(.NOT.ln_linssh )   CALL dom_vvl_sf_nxt( kstp )  ! after vertical scale factors  
    183184                            CALL wzv           ( kstp )  ! now cross-level velocity  
    184 !!gm : why also here ???? 
    185       IF( ln_sto_eos    )   CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    186 !!gm 
    187185                            CALL eos    ( tsn, rhd, rhop, gdept_n(:,:,:) )  ! now in situ density for hpg computation 
    188186                             
    … …  
    203201 
    204202      IF(  lk_asminc .AND. ln_asmiau .AND. ln_dyninc )   & 
    205                          CALL dyn_asm_inc   ( kstp )  ! apply dynamics assimilation increment 
     203               &         CALL dyn_asm_inc   ( kstp )  ! apply dynamics assimilation increment 
    206204      IF( lk_bdy     )   CALL bdy_dyn3d_dmp ( kstp )  ! bdy damping trends 
    207205#if defined key_agrif 
    … …  
    305303!!jc: That would be better, but see comment above 
    306304!! 
    307       IF( lrst_oce   )   CALL rst_write     ( kstp )  ! write output ocean restart file 
     305      IF( lrst_oce   )   CALL rst_write    ( kstp )   ! write output ocean restart file 
     306      IF( ln_sto_eos )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
    308307 
    309308#if defined key_agrif 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

    r6140 r6851  
    131131         ! 
    132132         CALL p4z_bio( kt, jnt )   ! Biology 
    133          CALL p4z_sed( kt, jnt )   ! Sedimentation 
    134133         CALL p4z_lys( kt, jnt )   ! Compute CaCO3 saturation 
     134         CALL p4z_sed( kt, jnt )   ! Surface and Bottom boundary conditions 
    135135         CALL p4z_flx( kt, jnt )   ! Compute surface fluxes 
    136136         ! 

  • branches/2016/dev_r6325_SIMPLIF_1/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90

    r6140 r6851  
    4040   REAL(wp), PUBLIC ::   rn_ahtrc_0          !:   laplacian diffusivity coefficient for passive tracer [m2/s] 
    4141   REAL(wp), PUBLIC ::   rn_bhtrc_0          !: bilaplacian      -          --     -       -   [m4/s] 
     42   REAL(wp), PUBLIC ::   rn_fact_lap         !: Enhanced zonal diffusivity coefficent in the equatorial domain 
    4243   ! 
    4344   !                      !!: ** lateral mixing namelist (nam_trcldf) ** 
    … …  
    6465      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    6566      ! 
    66       INTEGER            :: jn 
     67      INTEGER            :: ji, jj, jk, jn 
     68      REAL(wp)           :: zdep 
    6769      CHARACTER (len=22) :: charout 
    6870      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zahu, zahv 
    … …  
    7678         ztrtrd(:,:,:,:)  = tra(:,:,:,:) 
    7779      ENDIF 
    78       ! 
    79       !                                        !* set the lateral diffusivity coef. for passive tracer       
     80      !                                  !* set the lateral diffusivity coef. for passive tracer       
    8081      CALL wrk_alloc( jpi,jpj,jpk,   zahu, zahv ) 
    81       zahu(:,:,:) = rldf * ahtu(:,:,:) 
     82      zahu(:,:,:) = rldf * ahtu(:,:,:)  
    8283      zahv(:,:,:) = rldf * ahtv(:,:,:) 
    83  
     84      !                                  !* Enhanced zonal diffusivity coefficent in the equatorial domain 
     85      DO jk= 1, jpk 
     86         DO jj = 1, jpj 
     87            DO ji = 1, jpi 
     88               IF( gdept_n(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 
     89                  zdep = MAX( gdept_n(ji,jj,jk) - 1000., 0. ) / 1000. 
     90                  zahu(ji,jj,jk) = zahu(ji,jj,jk) * MAX( 1., rn_fact_lap * EXP( -zdep ) ) 
     91               ENDIF 
     92            END DO 
     93         END DO 
     94      END DO 
     95      ! 
    8496      SELECT CASE ( nldf )                     !* compute lateral mixing trend and add it to the general trend 
    8597      ! 
    … …  
    136148      NAMELIST/namtrc_ldf/ ln_trcldf_lap, ln_trcldf_blp,                                  & 
    137149         &                 ln_trcldf_lev, ln_trcldf_hor, ln_trcldf_iso, ln_trcldf_triad,  & 
    138          &                 rn_ahtrc_0   , rn_bhtrc_0 
     150         &                 rn_ahtrc_0   , rn_bhtrc_0, rn_fact_lap   
    139151      !!---------------------------------------------------------------------- 
    140152      ! 
    … …  
    164176         WRITE(numout,*) '           laplacian                 rn_ahtrc_0      = ', rn_ahtrc_0 
    165177         WRITE(numout,*) '         bilaplacian                 rn_bhtrc_0      = ', rn_bhtrc_0 
     178         WRITE(numout,*) '      enhanced zonal diffusivity     rn_fact_lap     = ', rn_fact_lap 
     179 
    166180      ENDIF 
    167181      !       
Note: See TracChangeset for help on using the changeset viewer.