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 7487 – NEMO

Changeset 7487


Ignore:
Timestamp:
2016-12-12T11:53:26+01:00 (7 years ago)
Author:
timgraham
Message:

Merged head of v3.6 Stable into NEMOGCM/NEMO

Location:
branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO
Files:
51 edited

Legend:

Unmodified
Added
Removed
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r6427 r7487  
    234234   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce, v_oce   !: surface ocean velocity used in ice dynamics 
    235235   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ahiu , ahiv    !: hor. diffusivity coeff. at U- and V-points [m2/s] 
    236    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   pahu , pahv    !: ice hor. eddy diffusivity coef. at U- and V-points 
    237236   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ust2s, hicol   !: friction velocity, ice collection thickness accreted in leads 
    238237   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   strp1, strp2   !: strength at previous time steps 
     
    244243   ! 
    245244   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sist        !: Average Sea-Ice Surface Temperature [Kelvin] 
    246    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   icethi      !: total ice thickness (for all categories) (diag only) 
    247245   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   t_bo        !: Sea-Ice bottom temperature [Kelvin]      
    248246   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   frld        !: Leads fraction = 1 - ice fraction 
     
    303301   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
    304302 
    305    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
     303   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice    
     304   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   pahu3D , pahv3D 
    306305   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    307306 
     
    320319   !                                                                  !  this is an extensive variable that has to be transported 
    321320   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   o_i     !: Sea-Ice Age (days) 
    322    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ov_i    !: Sea-Ice Age times volume per area (days.m) 
    323321   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   oa_i    !: Sea-Ice Age times ice area (days) 
     322   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   bv_i    !: brine volume 
    324323 
    325324   !! Variables summed over all categories, or associated to all the ice in a single grid cell 
    326325   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice   !: components of the ice velocity (m/s) 
    327    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tio_u, tio_v   !: components of the ice-ocean stress (N/m2) 
    328326   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i , vt_s    !: ice and snow total volume per unit area (m) 
    329327   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   at_i           !: ice total fractional area (ice concentration) 
    330328   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i          !: =1-at_i ; total open water fractional area 
    331329   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i , et_s    !: ice and snow total heat content 
    332    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ot_i           !: mean age over all categories 
    333    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i           !: mean ice temperature over all categories 
    334    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bv_i           !: brine volume averaged over all categories 
    335    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i          !: mean sea ice salinity averaged over all categories [PSU] 
     330   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i         !: mean ice temperature over all categories 
     331   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bvm_i        !: brine volume averaged over all categories 
     332   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i        !: mean sea ice salinity averaged over all categories [PSU] 
     333   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_su        !: mean surface temperature over all categories 
     334   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htm_i        !: mean ice  thickness over all categories 
     335   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   htm_s        !: mean snow thickness over all categories 
     336   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   om_i         !: mean ice age over all categories 
    336337 
    337338   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s        !: Snow temperatures [K] 
     
    429430      ALLOCATE( u_oce    (jpi,jpj) , v_oce    (jpi,jpj) ,                           & 
    430431         &      ahiu     (jpi,jpj) , ahiv     (jpi,jpj) ,                           & 
    431          &      pahu     (jpi,jpj) , pahv     (jpi,jpj) ,                           & 
    432432         &      ust2s    (jpi,jpj) , hicol    (jpi,jpj) ,                           & 
    433433         &      strp1    (jpi,jpj) , strp2    (jpi,jpj) , strength  (jpi,jpj) ,     & 
     
    436436 
    437437      ii = ii + 1 
    438       ALLOCATE( sist   (jpi,jpj) , icethi (jpi,jpj) , t_bo   (jpi,jpj) ,                        & 
     438      ALLOCATE( sist   (jpi,jpj) , t_bo   (jpi,jpj) ,                        & 
    439439         &      frld   (jpi,jpj) , pfrld  (jpi,jpj) , phicif (jpi,jpj) ,                        & 
    440440         &      wfx_snw(jpi,jpj) , wfx_ice(jpi,jpj) , wfx_sub(jpi,jpj) ,                        & 
     
    442442         &      wfx_res(jpi,jpj) , wfx_sni(jpi,jpj) , wfx_opw(jpi,jpj) , wfx_spr(jpi,jpj) ,     & 
    443443         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
    444          &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), qlead  (jpi,jpj) ,                     & 
    445          &      rn_amax_2d(jpi,jpj),                                                            & 
    446          &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj) ,                       & 
     444         &      fhtur  (jpi,jpj) , ftr_ice(jpi,jpj,jpl), pahu3D(jpi,jpj,jpl+1), pahv3D(jpi,jpj,jpl+1),            & 
     445         &      qlead  (jpi,jpj) , rn_amax_2d(jpi,jpj),                                         & 
     446         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) , sfx_sub(jpi,jpj),      & 
    447447         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    448448         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
     
    457457         &      v_s  (jpi,jpj,jpl) , ht_s (jpi,jpj,jpl) , t_su (jpi,jpj,jpl) ,     & 
    458458         &      sm_i (jpi,jpj,jpl) , smv_i(jpi,jpj,jpl) , o_i  (jpi,jpj,jpl) ,     & 
    459          &      ov_i (jpi,jpj,jpl) , oa_i (jpi,jpj,jpl)                      , STAT=ierr(ii) ) 
    460       ii = ii + 1 
    461       ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) , tio_u(jpi,jpj) , tio_v(jpi,jpj) ,     & 
     459         &      oa_i (jpi,jpj,jpl) , bv_i (jpi,jpj,jpl) , STAT=ierr(ii) ) 
     460      ii = ii + 1 
     461      ALLOCATE( u_ice(jpi,jpj) , v_ice(jpi,jpj) ,      & 
    462462         &      vt_i (jpi,jpj) , vt_s (jpi,jpj) , at_i (jpi,jpj) , ato_i(jpi,jpj) ,     & 
    463          &      et_i (jpi,jpj) , et_s (jpi,jpj) , ot_i (jpi,jpj) , tm_i (jpi,jpj) ,     & 
    464          &      bv_i (jpi,jpj) , smt_i(jpi,jpj)                                   , STAT=ierr(ii) ) 
     463         &      et_i (jpi,jpj) , et_s (jpi,jpj) , tm_i (jpi,jpj) , bvm_i(jpi,jpj) ,     & 
     464         &      smt_i(jpi,jpj) , tm_su(jpi,jpj) , htm_i(jpi,jpj) , htm_s(jpi,jpj) ,     & 
     465         &      om_i (jpi,jpj)                              , STAT=ierr(ii) ) 
    465466      ii = ii + 1 
    466467      ALLOCATE( t_s(jpi,jpj,nlay_s,jpl) , e_s(jpi,jpj,nlay_s,jpl) , STAT=ierr(ii) ) 
     
    514515   !!====================================================================== 
    515516END MODULE ice 
     517 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r6427 r7487  
    288288#if ! defined key_bdy 
    289289      ! heat flux 
    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          &              * e12t * tmask(:,:,1) * zconv )  
     290      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es  & 
     291      !  &              - SUM( qevap_ice * a_i_b, dim=3 )                           & !!clem: I think this line must be commented (but need check) 
     292         &              ) * e12t * tmask(:,:,1) * zconv )  
    292293      ! salt flux 
    293294      zsfx  = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

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

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

    r6427 r7487  
    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 
     
    246247               ztest_1 = 1 
    247248            ELSE  
    248               ! this write is useful 
    249               IF(lwp)  WRITE(numout,*) ' * TEST1 AREA NOT CONSERVED *** zA_cons = ', zA_cons,' zat_i_ini = ',zat_i_ini(i_hemis)  
    250249               ztest_1 = 0 
    251250            ENDIF 
     
    258257               ztest_2 = 1 
    259258            ELSE 
    260               ! this write is useful 
    261               IF(lwp)  WRITE(numout,*) ' * TEST2 VOLUME NOT CONSERVED *** zV_cons = ', zV_cons, & 
    262                             ' zvt_i_ini = ', zvt_i_ini(i_hemis) 
    263259               ztest_2 = 0 
    264260            ENDIF 
     
    268264               ztest_3 = 1 
    269265            ELSE 
    270                ! this write is useful 
    271                IF(lwp) WRITE(numout,*) ' * TEST 3 THICKNESS OF THE LAST CATEGORY OUT OF BOUNDS *** zh_i_ini(i_fill,i_hemis) = ', & 
    272                zh_i_ini(i_fill,i_hemis), ' hi_max(jpl-1) = ', hi_max(i_fill-1) 
    273266               ztest_3 = 0 
    274267            ENDIF 
     
    278271            DO jl = 1, jpl 
    279272               IF ( za_i_ini(jl,i_hemis) .LT. 0._wp ) THEN  
    280                   ! this write is useful 
    281                   IF(lwp) WRITE(numout,*) ' * TEST 4 POSITIVITY NOT OK FOR CAT ', jl, ' WITH A = ', za_i_ini(jl,i_hemis) 
    282273                  ztest_4 = 0 
    283274               ENDIF 
     
    337328         END DO 
    338329      END DO 
     330 
     331      ! for constant salinity in time 
     332      IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     333         CALL lim_var_salprof 
     334         smv_i = sm_i * v_i 
     335      ENDIF 
    339336 
    340337      ! Snow temperature and heat content 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r6427 r7487  
    651651            wfx_dyn(ji,jj) = wfx_dyn(ji,jj) - vsw (ij) * rhoic * r1_rdtice   ! increase in ice volume due to seawater frozen in voids 
    652652             
     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 
    653660            !------------------------------------------             
    654661            ! 3.7 Put the snow somewhere in the ocean 
     
    664671            hfx_dyn(ji,jj) = hfx_dyn(ji,jj) + ( - esrdg(ij) * ( 1._wp - rn_fsnowrdg )         &  
    665672               &                                - esrft(ij) * ( 1._wp - rn_fsnowrft ) ) * r1_rdtice        ! heat sink for ocean (<0, W.m-2) 
    666  
     673                
    667674            !----------------------------------------------------------------- 
    668675            ! 3.8 Compute quantities used to apportion ice among categories 
     
    859866         DO jj = 1, jpj 
    860867            DO ji = 1, jpi 
    861                strength(ji,jj) = strength(ji,jj) * exp(-5.88*SQRT(MAX(bv_i(ji,jj),0.0))) 
     868               strength(ji,jj) = strength(ji,jj) * exp(-5.88*SQRT(MAX(bvm_i(ji,jj),0.0))) 
    862869            END DO 
    863870         END DO 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

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

    r6427 r7487  
    110110      !!--------------------------------------------------------------------- 
    111111 
    112       ! 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) 
    114       IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    115       IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    116       IF( iom_use('qsr_ice') )   CALL iom_put( "qsr_ice" , SUM( qsr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux at ice surface 
    117       IF( iom_use('qns_ice') )   CALL iom_put( "qns_ice" , SUM( qns_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) ! non-solar flux at ice surface 
    118       IF( iom_use('qtr_ice') )   CALL iom_put( "qtr_ice" , SUM( ftr_ice(:,:,:) * a_i_b(:,:,:), dim=3 ) )                 !     solar flux transmitted thru ice 
    119       IF( iom_use('qt_oce' ) )   CALL iom_put( "qt_oce"  , ( qsr_oce(:,:) + qns_oce(:,:) ) * pfrld(:,:) + qemp_oce(:,:) )   
    120       IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    121          &                                                      * a_i_b(:,:,:), dim=3 ) + qemp_ice(:,:) ) 
    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 
     112      ! make call for albedo output before it is modified 
    128113      CALL wrk_alloc( jpi,jpj, zalb )     
    129114 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r6427 r7487  
    116116 
    117117      ! Discriminate between varying salinity (nn_icesal=2) and prescribed cases (other values) 
    118       SELECT CASE( nn_icesal )                       ! varying salinity or not 
    119          CASE( 1, 3, 4 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
    120          CASE( 2 )       ;   zswitch_sal = 1       ! varying salinity profile 
     118      SELECT CASE( nn_icesal )                  ! varying salinity or not 
     119         CASE( 1, 3 ) ;   zswitch_sal = 0       ! prescribed salinity profile 
     120         CASE( 2 )    ;   zswitch_sal = 1       ! varying salinity profile 
    121121      END SELECT 
    122122 
     
    651651 
    652652         ! Contribution to energy flux to the ocean [J/m2], >0 (if sst<0) 
    653          ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    654653         zfmdt          = ( rhosn - rhoic ) * MAX( dh_snowice(ji), 0._wp )    ! <0 
    655654         zsstK          = sst_m(ii,ij) + rt0                                 
     
    662661         ! Contribution to salt flux 
    663662         sfx_sni_1d(ji) = sfx_sni_1d(ji) + sss_m(ii,ij) * a_i_1d(ji) * zfmdt * r1_rdtice  
     663 
     664         ! virtual salt flux to keep salinity constant 
     665         IF( nn_icesal == 1 .OR. nn_icesal == 3 )  THEN 
     666            sfx_bri_1d(ji) = sfx_bri_1d(ji) - sss_m(ii,ij) * a_i_1d(ji) * zfmdt                  * r1_rdtice  & ! put back sss_m into the ocean 
     667               &                            - sm_i_1d(ji)  * a_i_1d(ji) * dh_snowice(ji) * rhoic * r1_rdtice    ! and get  sm_i  from the ocean  
     668         ENDIF 
    664669           
    665670         ! Contribution to mass flux 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r6427 r7487  
    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/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

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

    r6427 r7487  
    5454   PUBLIC   lim_var_eqv2glo       
    5555   PUBLIC   lim_var_salprof       
    56    PUBLIC   lim_var_icetm         
    5756   PUBLIC   lim_var_bv            
    5857   PUBLIC   lim_var_salprof1d     
     
    8988      ! Compute variables 
    9089      !-------------------- 
    91       vt_i (:,:) = 0._wp 
    92       vt_s (:,:) = 0._wp 
    93       at_i (:,:) = 0._wp 
    94       ato_i(:,:) = 1._wp 
    95       ! 
    96       DO jl = 1, jpl 
    97          DO jj = 1, jpj 
    98             DO ji = 1, jpi 
    99                ! 
    100                vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 
    101                vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 
    102                at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 
    103                ! 
    104                rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )  
    105                icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch  ! ice thickness 
    106             END DO 
    107          END DO 
    108       END DO 
    109  
     90      ! integrated values 
     91      vt_i (:,:) = SUM( v_i, dim=3 ) 
     92      vt_s (:,:) = SUM( v_s, dim=3 ) 
     93      at_i (:,:) = SUM( a_i, dim=3 ) 
     94      et_s(:,:)  = SUM( SUM( e_s(:,:,:,:), dim=4 ), dim=3 ) 
     95      et_i(:,:)  = SUM( SUM( e_i(:,:,:,:), dim=4 ), dim=3 ) 
     96      ! 
    11097      DO jj = 1, jpj 
    11198         DO ji = 1, jpi 
     
    115102 
    116103      IF( kn > 1 ) THEN 
    117          et_s (:,:) = 0._wp 
    118          ot_i (:,:) = 0._wp 
     104         ! 
     105         ! mean ice/snow thickness 
     106         DO jj = 1, jpj 
     107            DO ji = 1, jpi 
     108               rswitch      = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) )  
     109               htm_i(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch 
     110               htm_s(ji,jj) = vt_s(ji,jj) / MAX( at_i(ji,jj) , epsi10 ) * rswitch 
     111            ENDDO 
     112         ENDDO 
     113 
     114         ! mean temperature (K), salinity and age 
    119115         smt_i(:,:) = 0._wp 
    120          et_i (:,:) = 0._wp 
    121          ! 
     116         tm_i(:,:)  = 0._wp 
     117         tm_su(:,:) = 0._wp 
     118         om_i (:,:) = 0._wp 
    122119         DO jl = 1, jpl 
     120             
    123121            DO jj = 1, jpj 
    124122               DO ji = 1, jpi 
    125                   et_s(ji,jj)  = et_s(ji,jj)  + e_s(ji,jj,1,jl)                                           ! snow heat content 
    126                   rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi20 ) )  
    127                   smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , epsi20 ) * rswitch   ! ice salinity 
    128                   rswitch = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi20 ) )  
    129                   ot_i(ji,jj)  = ot_i(ji,jj)  + oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , epsi20 ) * rswitch   ! ice age 
    130                END DO 
    131             END DO 
    132          END DO 
    133          ! 
    134          DO jl = 1, jpl 
     123                  rswitch      = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) 
     124                  tm_su(ji,jj) = tm_su(ji,jj) + rswitch * ( t_su(ji,jj,jl) - rt0 ) * a_i(ji,jj,jl) / MAX( at_i(ji,jj) , epsi10 ) 
     125                  om_i (ji,jj) = om_i (ji,jj) + rswitch *   oa_i(ji,jj,jl)                         / MAX( at_i(ji,jj) , epsi10 ) 
     126               END DO 
     127            END DO 
     128             
    135129            DO jk = 1, nlay_i 
    136                et_i(:,:) = et_i(:,:) + e_i(:,:,jk,jl)       ! ice heat content 
    137             END DO 
    138          END DO 
     130               DO jj = 1, jpj 
     131                  DO ji = 1, jpi 
     132                     rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     133                     tm_i(ji,jj)  = tm_i(ji,jj)  + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
     134                        &            / MAX( vt_i(ji,jj) , epsi10 ) 
     135                     smt_i(ji,jj) = smt_i(ji,jj) + r1_nlay_i * rswitch * s_i(ji,jj,jk,jl) * v_i(ji,jj,jl)  & 
     136                        &            / MAX( vt_i(ji,jj) , epsi10 ) 
     137                  END DO 
     138               END DO 
     139            END DO 
     140         END DO 
     141         tm_i  = tm_i  + rt0 
     142         tm_su = tm_su + rt0 
    139143         ! 
    140144      ENDIF 
     
    246250      ! Mean temperature 
    247251      !------------------- 
    248       vt_i (:,:) = 0._wp 
    249       DO jl = 1, jpl 
    250          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    251       END DO 
     252      ! integrated values 
     253      vt_i (:,:) = SUM( v_i, dim=3 ) 
     254      vt_s (:,:) = SUM( v_s, dim=3 ) 
     255      at_i (:,:) = SUM( a_i, dim=3 ) 
    252256 
    253257      tm_i(:,:) = 0._wp 
     
    314318      ! Vertically constant, constant in time 
    315319      !--------------------------------------- 
    316       IF(  nn_icesal == 1  )   s_i(:,:,:,:) = rn_icesal 
     320      IF(  nn_icesal == 1  )  THEN 
     321         s_i (:,:,:,:) = rn_icesal 
     322         sm_i(:,:,:)   = rn_icesal 
     323      ENDIF 
    317324 
    318325      !----------------------------------- 
     
    394401   END SUBROUTINE lim_var_salprof 
    395402 
    396  
    397    SUBROUTINE lim_var_icetm 
    398       !!------------------------------------------------------------------ 
    399       !!                ***  ROUTINE lim_var_icetm *** 
    400       !! 
    401       !! ** Purpose :   computes mean sea ice temperature 
     403   SUBROUTINE lim_var_bv 
     404      !!------------------------------------------------------------------ 
     405      !!                ***  ROUTINE lim_var_bv *** 
     406      !! 
     407      !! ** Purpose :   computes mean brine volume (%) in sea ice 
     408      !! 
     409      !! ** Method  : e = - 0.054 * S (ppt) / T (C) 
     410      !! 
     411      !! References : Vancoppenolle et al., JGR, 2007 
    402412      !!------------------------------------------------------------------ 
    403413      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    404414      !!------------------------------------------------------------------ 
    405  
    406       ! Mean sea ice temperature 
    407       vt_i (:,:) = 0._wp 
    408       DO jl = 1, jpl 
    409          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    410       END DO 
    411  
    412       tm_i(:,:) = 0._wp 
     415      ! 
     416      bvm_i(:,:)   = 0._wp 
     417      bv_i (:,:,:) = 0._wp 
    413418      DO jl = 1, jpl 
    414419         DO jk = 1, nlay_i 
    415420            DO jj = 1, jpj 
    416421               DO ji = 1, jpi 
    417                   rswitch = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
    418                   tm_i(ji,jj) = tm_i(ji,jj) + r1_nlay_i * rswitch * ( t_i(ji,jj,jk,jl) - rt0 ) * v_i(ji,jj,jl)  & 
    419                      &            / MAX( vt_i(ji,jj) , epsi10 ) 
    420                END DO 
    421             END DO 
    422          END DO 
    423       END DO 
    424       tm_i = tm_i + rt0 
    425  
    426    END SUBROUTINE lim_var_icetm 
    427  
    428  
    429    SUBROUTINE lim_var_bv 
    430       !!------------------------------------------------------------------ 
    431       !!                ***  ROUTINE lim_var_bv *** 
    432       !! 
    433       !! ** Purpose :   computes mean brine volume (%) in sea ice 
    434       !! 
    435       !! ** Method  : e = - 0.054 * S (ppt) / T (C) 
    436       !! 
    437       !! References : Vancoppenolle et al., JGR, 2007 
    438       !!------------------------------------------------------------------ 
    439       INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    440       REAL(wp) ::   zbvi             ! local scalars 
    441       !!------------------------------------------------------------------ 
    442       ! 
    443       vt_i (:,:) = 0._wp 
    444       DO jl = 1, jpl 
    445          vt_i(:,:) = vt_i(:,:) + v_i(:,:,jl) 
    446       END DO 
    447  
    448       bv_i(:,:) = 0._wp 
    449       DO jl = 1, jpl 
    450          DO jk = 1, nlay_i 
    451             DO jj = 1, jpj 
    452                DO ji = 1, jpi 
    453                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rt0) + epsi10 ) )  ) 
    454                   zbvi  = - rswitch * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - rt0, - epsi10 )   & 
    455                      &                   * v_i(ji,jj,jl) * r1_nlay_i 
    456                   rswitch = (  1._wp - MAX( 0._wp , SIGN( 1._wp , - vt_i(ji,jj) + epsi20 ) )  ) 
    457                   bv_i(ji,jj) = bv_i(ji,jj) + rswitch * zbvi  / MAX( vt_i(ji,jj) , epsi20 ) 
    458                END DO 
     422                  rswitch        = ( 1._wp - MAX( 0._wp , SIGN( 1._wp , (t_i(ji,jj,jk,jl) - rt0) + epsi10 ) )  ) 
     423                  bv_i(ji,jj,jl) = bv_i(ji,jj,jl) - rswitch * tmut * s_i(ji,jj,jk,jl) * r1_nlay_i  & 
     424                     &                            / MIN( t_i(ji,jj,jk,jl) - rt0, - epsi10 ) 
     425               END DO 
     426            END DO 
     427         END DO 
     428          
     429         DO jj = 1, jpj 
     430            DO ji = 1, jpi 
     431               rswitch      = MAX( 0._wp , SIGN( 1._wp , vt_i(ji,jj) - epsi10 ) ) 
     432               bvm_i(ji,jj) = bvm_i(ji,jj) + rswitch * bv_i(ji,jj,jl) * v_i(ji,jj,jl) / MAX( vt_i(ji,jj), epsi10 ) 
    459433            END DO 
    460434         END DO 
     
    712686            zht_i(ji,1:jpl) = 0._wp 
    713687            za_i (ji,1:jpl) = 0._wp 
    714              
     688            itest(:)        = 0       
     689       
    715690            ! *** case very thin ice: fill only category 1 
    716691            IF ( i_fill == 1 ) THEN 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

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

    r6427 r7487  
    392392      INTEGER :: ji,jj,jn 
    393393      REAL(wp) :: zalpha 
    394       REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr  
    395394      !!-----------------------------------------------------------------------       
    396395      ! 
     
    529528            END DO 
    530529         END DO 
     530      ELSE 
     531         DO jj=MAX(j1,2),j2 
     532            DO ji=MAX(i1,2),i2 
     533               uice_agr(ji,jj) = tabres(ji,jj) 
     534            END DO 
     535         END DO 
    531536      ENDIF 
    532537#else 
     
    541546            END DO 
    542547         END DO 
     548      ELSE 
     549         DO jj= j1, j2 
     550            DO ji= i1, i2 
     551               uice_agr(ji,jj) = tabres(ji,jj) 
     552            END DO 
     553         END DO 
    543554      ENDIF 
    544555#endif 
     
    566577                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    567578               ENDIF 
     579            END DO 
     580         END DO 
     581      ELSE 
     582         DO jj=MAX(j1,2),j2 
     583            DO ji=MAX(i1,2),i2 
     584               vice_agr(ji,jj) = tabres(ji,jj) 
    568585            END DO 
    569586         END DO 
     
    580597            END DO 
    581598         END DO 
     599      ELSE 
     600         DO jj= j1 ,j2 
     601            DO ji = i1, i2 
     602               vice_agr(ji,jj) = tabres(ji,jj) 
     603            END DO 
     604         END DO 
    582605      ENDIF 
    583606#endif 
     
    585608 
    586609 
    587    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 
     610   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, k1, k2, before ) 
    588611      !!----------------------------------------------------------------------- 
    589612      !!                    *** ROUTINE interp_adv_ice ***                            
     
    593616      !!              put -9999 where no ice for correct extrapolation              
    594617      !!----------------------------------------------------------------------- 
    595       INTEGER, INTENT(in) :: i1, i2, j1, j2 
    596       REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
     618      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
     619      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    597620      LOGICAL, INTENT(in) :: before 
    598621      !! 
     
    601624      ! 
    602625      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.  
    607                ELSE 
    608                   tabres(ji,jj, 1) = frld  (ji,jj) 
    609                   tabres(ji,jj, 2) = hicif (ji,jj) 
    610                   tabres(ji,jj, 3) = hsnif (ji,jj) 
    611                   tabres(ji,jj, 4) = tbif  (ji,jj,1) 
    612                   tabres(ji,jj, 5) = tbif  (ji,jj,2) 
    613                   tabres(ji,jj, 6) = tbif  (ji,jj,3) 
    614                   tabres(ji,jj, 7) = qstoif(ji,jj) 
    615                ENDIF 
    616             END DO 
    617          END DO 
     626         DO jj=j1,j2 
     627       DO ji=i1,i2 
     628          IF( tms(ji,jj) == 0. ) THEN 
     629             tabres(ji,jj,:) = -9999  
     630          ELSE 
     631             tabres(ji,jj, 1) = frld  (ji,jj) 
     632             tabres(ji,jj, 2) = hicif (ji,jj) 
     633             tabres(ji,jj, 3) = hsnif (ji,jj) 
     634             tabres(ji,jj, 4) = tbif  (ji,jj,1) 
     635             tabres(ji,jj, 5) = tbif  (ji,jj,2) 
     636             tabres(ji,jj, 6) = tbif  (ji,jj,3) 
     637             tabres(ji,jj, 7) = qstoif(ji,jj) 
     638          ENDIF 
     639       END DO 
     640         END DO 
     641      ELSE 
     642    DO jj=j1,j2 
     643       DO ji=i1,i2 
     644               DO jk=k1, k2 
     645             tabice_agr(ji,jj,jk) = tabres(ji,jj,jk) 
     646               END DO 
     647       END DO 
     648    END DO 
    618649      ENDIF 
    619650      ! 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/C1D/step_c1d.F90

    r6427 r7487  
    6060 
    6161                             indic = 0                ! reset to no error condition 
    62       IF( kstp == nit000 )   CALL iom_init( "nemo")   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
     62      IF( kstp == nit000 )   CALL iom_init( cxios_context )   ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) 
    6363      IF( kstp /= nit000 )   CALL day( kstp )         ! Calendar (day was already called at nit000 in day_init) 
    64                              CALL iom_setkt( kstp - nit000 + 1, "nemo" )   ! say to iom that we are at time step kstp 
     64                             CALL iom_setkt( kstp - nit000 + 1, cxios_context )   ! say to iom that we are at time step kstp 
    6565 
    6666      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/DIA/diaar5.F90

    r7209 r7487  
    252252      REAL(wp) ::   zztmp   
    253253      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   zsaldta   ! Jan/Dec levitus salinity 
    254       ! reading initial file 
    255       LOGICAL  ::   ln_tsd_init      !: T & S data flag 
    256       LOGICAL  ::   ln_tsd_tradmp    !: internal damping toward input data flag 
    257       CHARACTER(len=100)            ::   cn_dir 
    258       TYPE(FLD_N)                   ::  sn_tem,sn_sal 
    259       INTEGER  ::   ios=0 
    260  
    261       NAMELIST/namtsd/ ln_tsd_init,ln_tsd_tradmp,cn_dir,sn_tem,sn_sal 
    262       ! 
    263  
    264       REWIND( numnam_ref )              ! Namelist namtsd in reference namelist : 
    265       READ  ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) 
    266 901   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in reference namelist for dia_ar5', lwp ) 
    267       REWIND( numnam_cfg )              ! Namelist namtsd in configuration namelist : Parameters of the run 
    268       READ  ( numnam_cfg, namtsd, IOSTAT = ios, ERR = 902 ) 
    269 902   IF( ios /= 0 ) CALL ctl_nam ( ios , ' namtsd in configuration namelist for dia_ar5', lwp ) 
    270       IF(lwm) WRITE ( numond, namtsd ) 
    271254      ! 
    272255      !!---------------------------------------------------------------------- 
     
    274257      IF( nn_timing == 1 )   CALL timing_start('dia_ar5_init') 
    275258      ! 
    276       CALL wrk_alloc( jpi , jpj , jpk, jpts, zsaldta ) 
     259      CALL wrk_alloc( jpi, jpj, jpk, 2, zsaldta ) 
    277260      !                                      ! allocate dia_ar5 arrays 
    278261      IF( dia_ar5_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'dia_ar5_init : unable to allocate arrays' ) 
     
    290273      IF( lk_mpp )   CALL mpp_sum( vol0 ) 
    291274 
    292       CALL iom_open ( TRIM( cn_dir )//TRIM(sn_sal%clname), inum ) 
    293       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,1), 1  ) 
    294       CALL iom_get  ( inum, jpdom_data, TRIM(sn_sal%clvar), zsaldta(:,:,:,2), 12 ) 
     275      CALL iom_open ( 'sali_ref_clim_monthly', inum ) 
     276      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,1), 1  ) 
     277      CALL iom_get  ( inum, jpdom_data, 'vosaline' , zsaldta(:,:,:,2), 12 ) 
    295278      CALL iom_close( inum ) 
     279 
    296280      sn0(:,:,:) = 0.5_wp * ( zsaldta(:,:,:,1) + zsaldta(:,:,:,2) )         
    297281      sn0(:,:,:) = sn0(:,:,:) * tmask(:,:,:) 
     
    308292      ENDIF 
    309293      ! 
    310       CALL wrk_dealloc( jpi , jpj , jpk, jpts, zsaldta ) 
     294      CALL wrk_dealloc( jpi, jpj, jpk, 2, zsaldta ) 
    311295      ! 
    312296      IF( nn_timing == 1 )   CALL timing_stop('dia_ar5_init') 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r6427 r7487  
    3838   PUBLIC   dia_hsb        ! routine called by step.F90 
    3939   PUBLIC   dia_hsb_init   ! routine called by nemogcm.F90 
    40    PUBLIC   dia_hsb_rst    ! routine called by step.F90 
    4140 
    4241   LOGICAL, PUBLIC ::   ln_diahsb   !: check the heat and salt budgets 
     
    8685      !!--------------------------------------------------------------------------- 
    8786      IF( nn_timing == 1 )   CALL timing_start('dia_hsb')       
     87      ! 
    8888      CALL wrk_alloc( jpi,jpj,   z2d0, z2d1 ) 
    8989      ! 
     
    174174      ENDDO 
    175175 
    176       ! Substract forcing from heat content, salt content and volume variations 
     176      ! ------------------------ ! 
     177      ! 3 -  Drifts              ! 
     178      ! ------------------------ ! 
    177179      zdiff_v1 = zdiff_v1 - frc_v 
    178180      IF( lk_vvl )   zdiff_v2 = zdiff_v2 - frc_v 
     
    187189 
    188190      ! ----------------------- ! 
    189       ! 3 - Diagnostics writing ! 
     191      ! 4 - Diagnostics writing ! 
    190192      ! ----------------------- ! 
    191193      zvol_tot = 0._wp                    ! total ocean volume (calculated with scale factors) 
     
    200202!!gm end 
    201203 
     204      CALL iom_put(   'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
     205      CALL iom_put(   'bgfrctem' , frc_t    * rau0 * rcp * 1.e-20 )   ! hc  - surface forcing (1.e20 J)  
     206      CALL iom_put(   'bgfrchfx' , frc_t    * rau0 * rcp /  &         ! hc  - surface forcing (W/m2)  
     207         &                       ( surf_tot * kt * rdt )        ) 
     208      CALL iom_put(   'bgfrcsal' , frc_s    * 1.e-9    )              ! sc  - surface forcing (psu*km3)  
     209 
    202210      IF( lk_vvl ) THEN 
    203         CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature variation (C)  
    204         CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    variation (psu) 
    205         CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content variation (1.e20 J)  
    206         CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content variation (psu*km3) 
    207         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    208         CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t variation (km3)   
    209         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    210         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    211         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     211        CALL iom_put( 'bgtemper' , zdiff_hc / zvol_tot )              ! Temperature drift     (C)  
     212        CALL iom_put( 'bgsaline' , zdiff_sc / zvol_tot )              ! Salinity    drift     (pss) 
     213        CALL iom_put( 'bgheatco' , zdiff_hc * 1.e-20 * rau0 * rcp )   ! Heat content drift    (1.e20 J)  
     214        CALL iom_put( 'bgheatfx' , zdiff_hc * rau0 * rcp /  &         ! Heat flux drift       (W/m2)  
     215           &                       ( surf_tot * kt * rdt )        ) 
     216        CALL iom_put( 'bgsaltco' , zdiff_sc * 1.e-9    )              ! Salt content drift    (psu*km3) 
     217        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
     218        CALL iom_put( 'bgvole3t' , zdiff_v2 * 1.e-9    )              ! volume e3t drift      (km3)   
    212219      ELSE 
    213         CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content variation (C)  
    214         CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content variation (psu) 
    215         CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content variation (1.e20 J)  
    216         CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content variation (psu*km3) 
    217         CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh variation (km3)   
    218         CALL iom_put( 'bgfrcvol' , frc_v    * 1.e-9    )              ! vol - surface forcing (km3)  
    219         CALL iom_put( 'bgfrctem' , frc_t / zvol_tot    )              ! hc  - surface forcing (C)  
    220         CALL iom_put( 'bgfrcsal' , frc_s / zvol_tot    )              ! sc  - surface forcing (psu)  
     220        CALL iom_put( 'bgtemper' , zdiff_hc1 / zvol_tot)              ! Heat content drift    (C)  
     221        CALL iom_put( 'bgsaline' , zdiff_sc1 / zvol_tot)              ! Salt content drift    (pss) 
     222        CALL iom_put( 'bgheatco' , zdiff_hc1 * 1.e-20 * rau0 * rcp )  ! Heat content drift    (1.e20 J)  
     223        CALL iom_put( 'bgheatfx' , zdiff_hc1 * rau0 * rcp /  &        ! Heat flux drift       (W/m2)  
     224           &                       ( surf_tot * kt * rdt )         ) 
     225        CALL iom_put( 'bgsaltco' , zdiff_sc1 * 1.e-9    )             ! Salt content drift    (psu*km3) 
     226        CALL iom_put( 'bgvolssh' , zdiff_v1 * 1.e-9    )              ! volume ssh drift      (km3)   
    221227        CALL iom_put( 'bgmistem' , zerr_hc1 / zvol_tot )              ! hc  - error due to free surface (C) 
    222228        CALL iom_put( 'bgmissal' , zerr_sc1 / zvol_tot )              ! sc  - error due to free surface (psu) 
     
    244250     ! 
    245251     INTEGER ::   ji, jj, jk   ! dummy loop indices 
    246      INTEGER ::   id1          ! local integers 
    247252     !!---------------------------------------------------------------------- 
    248253     ! 
    249254     IF( TRIM(cdrw) == 'READ' ) THEN        ! Read/initialise  
    250255        IF( ln_rstart ) THEN                   !* Read the restart file 
    251            !id1 = iom_varid( numror, 'frc_vol'  , ldstop = .FALSE. ) 
    252256           ! 
    253257           IF(lwp) WRITE(numout,*) '~~~~~~~' 
     
    261265              CALL iom_get( numror, 'frc_wn_s', frc_wn_s ) 
    262266           ENDIF 
    263            CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini ) 
    264            CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini ) 
    265            CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini ) 
    266            CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini ) 
     267           CALL iom_get( numror, jpdom_autoglo, 'ssh_ini', ssh_ini(:,:) ) 
     268           CALL iom_get( numror, jpdom_autoglo, 'e3t_ini', e3t_ini(:,:,:) ) 
     269           CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     270           CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    267271           IF( .NOT. lk_vvl ) THEN 
    268               CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    269               CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     272              CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     273              CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    270274           ENDIF 
    271275       ELSE 
     
    312316           CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s ) 
    313317        ENDIF 
    314         CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini ) 
    315         CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini ) 
    316         CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini ) 
    317         CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini ) 
     318        CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini', ssh_ini(:,:) ) 
     319        CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini', e3t_ini(:,:,:) ) 
     320        CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini(:,:,:) ) 
     321        CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini(:,:,:) ) 
    318322        IF( .NOT. lk_vvl ) THEN 
    319            CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini ) 
    320            CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini ) 
     323           CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini(:,:) ) 
     324           CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini(:,:) ) 
    321325        ENDIF 
     326 
    322327        ! 
    323328     ENDIF 
     
    338343      !!             - Compute coefficients for conversion 
    339344      !!--------------------------------------------------------------------------- 
    340       INTEGER ::   jk       ! dummy loop indice 
    341345      INTEGER ::   ierror   ! local integer 
    342346      INTEGER ::   ios 
     
    344348      NAMELIST/namhsb/ ln_diahsb 
    345349      !!---------------------------------------------------------------------- 
    346  
    347       IF(lwp) THEN 
    348          WRITE(numout,*) 
    349          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    350          WRITE(numout,*) '~~~~~~~~ ' 
    351       ENDIF 
    352350 
    353351      REWIND( numnam_ref )              ! Namelist namhsb in reference namelist 
     
    360358      IF(lwm) WRITE ( numond, namhsb ) 
    361359 
    362       ! 
    363       IF(lwp) THEN                   ! Control print 
     360      IF(lwp) THEN 
    364361         WRITE(numout,*) 
    365          WRITE(numout,*) 'dia_hsb_init : check the heat and salt budgets' 
    366          WRITE(numout,*) '~~~~~~~~~~~~' 
    367          WRITE(numout,*) '   Namelist namhsb : set hsb parameters' 
    368          WRITE(numout,*) '      Switch for hsb diagnostic (T) or not (F)  ln_diahsb  = ', ln_diahsb 
    369          WRITE(numout,*) 
    370       ENDIF 
    371  
     362         WRITE(numout,*) 'dia_hsb_init' 
     363         WRITE(numout,*) '~~~~~~~~ ' 
     364         WRITE(numout,*) '  check the heat and salt budgets (T) or not (F)       ln_diahsb = ', ln_diahsb 
     365      ENDIF 
     366      ! 
    372367      IF( .NOT. ln_diahsb )   RETURN 
    373368         !      IF( .NOT. lk_mpp_rep ) & 
     
    382377         &      e3t_ini(jpi,jpj,jpk), surf(jpi,jpj),  ssh_ini(jpi,jpj), STAT=ierror ) 
    383378      IF( ierror > 0 ) THEN 
    384          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
    385       ENDIF 
    386  
    387       IF(.NOT. lk_vvl ) ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj),STAT=ierror ) 
    388       IF( ierror > 0 ) THEN 
    389          CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' )   ;   RETURN 
     379         CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     380         RETURN 
     381      ENDIF 
     382 
     383      IF( .NOT. lk_vvl ) THEN 
     384         ALLOCATE( ssh_hc_loc_ini(jpi,jpj), ssh_sc_loc_ini(jpi,jpj), STAT=ierror ) 
     385         IF( ierror > 0 )   THEN 
     386            CALL ctl_stop( 'dia_hsb: unable to allocate hc_loc_ini' ) 
     387            RETURN 
     388         ENDIF 
    390389      ENDIF 
    391390 
     
    393392      ! 2 - Time independant variables and file opening ! 
    394393      ! ----------------------------------------------- ! 
    395       IF(lwp) WRITE(numout,*) "dia_hsb: heat salt volume budgets activated" 
    396       IF(lwp) WRITE(numout,*) '~~~~~~~' 
    397394      surf(:,:) = e1t(:,:) * e2t(:,:) * tmask_i(:,:)      ! masked surface grid cell area 
    398       surf_tot  = glob_sum( surf(:,:) )                                       ! total ocean surface area 
     395      surf_tot  = glob_sum( surf(:,:) )                   ! total ocean surface area 
    399396 
    400397      IF( lk_bdy ) CALL ctl_warn( 'dia_hsb does not take open boundary fluxes into account' )          
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/DOM/closea.F90

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

    r6427 r7487  
    601601            DO jk = 1, jpk 
    602602               DO jj = 1, jpjm1 
    603                   DO ji = 1, jpim1 
     603                  DO ji = 1, fs_jpim1 
    604604                     ze3  = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    605605                        &   + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) 
    606                      IF( ze3 /= 0._wp )   ze3f(ji,jj,jk) = 4.0_wp / ze3 
     606                     IF   ( ze3 /= 0._wp ) THEN ;   ze3f(ji,jj,jk) = 4.0_wp / ze3 
     607                     ELSE                       ;   ze3f(ji,jj,jk) = 0.0_wp 
     608                     ENDIF 
    607609                  END DO 
    608610               END DO 
     
    611613            DO jk = 1, jpk 
    612614               DO jj = 1, jpjm1 
    613                   DO ji = 1, jpim1 
     615                  DO ji = 1, fs_jpim1 
    614616                     ze3  = ( fse3t(ji,jj+1,jk)*tmask(ji,jj+1,jk) + fse3t(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk)   & 
    615617                        &   + fse3t(ji,jj  ,jk)*tmask(ji,jj  ,jk) + fse3t(ji+1,jj  ,jk)*tmask(ji+1,jj  ,jk) ) 
    616618                     zmsk = (                   tmask(ji,jj+1,jk) +                     tmask(ji+1,jj+1,jk)   & 
    617619                        &                     + tmask(ji,jj  ,jk) +                     tmask(ji+1,jj  ,jk) ) 
    618                      IF( ze3 /= 0._wp )   ze3f(ji,jj,jk) = zmsk / ze3 
     620                     IF   ( ze3 /= 0._wp ) THEN ;   ze3f(ji,jj,jk) = zmsk / ze3 
     621                     ELSE                       ;   ze3f(ji,jj,jk) = 0.0_wp 
     622                     ENDIF 
    619623                  END DO 
    620624               END DO 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/DYN/dynzdf_imp.F90

    r6427 r7487  
    323323            ze3va =  ( 1._wp - r_vvl ) * fse3v_n(ji,jj,1) + r_vvl   * fse3v_a(ji,jj,1)  
    324324            va(ji,jj,1) = va(ji,jj,1) + p2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    325                &                                      / ( ze3va * rau0 )  
     325               &                                      / ( ze3va * rau0 ) * vmask(ji,jj,1) 
    326326#else 
    327327            va(ji,jj,1) = vb(ji,jj,1) & 
    328328               &                   + p2dt *(va(ji,jj,1) +  0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) )   & 
    329                &                                                       / ( fse3v(ji,jj,1) * rau0     ) ) 
     329               &                                      / ( fse3v(ji,jj,1) * rau0     ) * vmask(ji,jj,1) ) 
    330330#endif 
    331331         END DO 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90

    r6427 r7487  
    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/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90

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

    r6427 r7487  
    804804            ELSE 
    805805               startloop = 3 
    806                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     806               pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    807807            ENDIF 
    808808            DO ji = startloop, nlci 
     
    816816            ELSE 
    817817               startloop = 3 
    818                pt2dl(2,ijpj) = psgn * pt2dr(3,ijpjm1) 
     818               pt2dl(2,ijpj) = psgn * pt2dl(3,ijpjm1) 
    819819            ENDIF 
    820820            DO ji = startloop, nlci 
     
    910910               DO ji = startloop , endloop 
    911911                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    912                   pt2dl(ji,ijpj)= 0.5 * (pt2dr(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
     912                  pt2dl(ji,ijpj)= 0.5 * (pt2dl(ji,ijpjm1) + psgn * pt2dr(ijt,ijpjm1)) 
    913913               END DO 
    914914 
     
    926926               DO ji = startloop , endloop 
    927927                  ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 
    928                   pt2dl(ji,ijpj) = pt2dr(ji,ijpjm1) 
     928                  pt2dl(ji,ijpj) = pt2dl(ji,ijpjm1) 
    929929               END DO 
    930930 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6427 r7487  
    2424   !!            3.5  !  2013  ( C. Ethe, G. Madec ) message passing arrays as local variables  
    2525   !!            3.5  !  2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 
     26   !!            3.6  !  2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple'  
    2627   !!---------------------------------------------------------------------- 
    2728 
     
    6263   USE lbcnfd         ! north fold treatment 
    6364   USE in_out_manager ! I/O manager 
     65   USE wrk_nemo       ! work arrays 
    6466 
    6567   IMPLICIT NONE 
     
    7072   PUBLIC   mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 
    7173   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     74   PUBLIC   mpp_max_multiple 
    7275   PUBLIC   mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 
    73    PUBLIC   mpp_lnk_2d_9  
     76   PUBLIC   mpp_lnk_2d_9 , mpp_lnk_2d_multiple  
    7477   PUBLIC   mppscatter, mppgather 
    7578   PUBLIC   mpp_ini_ice, mpp_ini_znl 
     
    7881   PUBLIC   mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 
    7982   PUBLIC   mpp_lbc_north_icb, mpp_lnk_2d_icb 
     83   PUBLIC   mpprank 
    8084 
    8185   TYPE arrayptr 
    8286      REAL , DIMENSION (:,:),  POINTER :: pt2d 
    8387   END TYPE arrayptr 
     88   PUBLIC   arrayptr 
    8489    
    8590   !! * Interfaces 
     
    105110   INTERFACE mpp_maxloc 
    106111      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
     112   END INTERFACE 
     113 
     114   INTERFACE mpp_max_multiple 
     115      MODULE PROCEDURE mppmax_real_multiple 
    107116   END INTERFACE 
    108117 
     
    732741      ! ----------------------- 
    733742      ! 
    734       DO ii = 1 , num_fields 
    735743         !First Array 
    736          IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
    737             ! 
    738             SELECT CASE ( jpni ) 
    739             CASE ( 1 )     ;   CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
    740             CASE DEFAULT   ;   CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) )   ! for all northern procs. 
    741             END SELECT 
    742             ! 
    743          ENDIF 
    744          ! 
    745       END DO 
     744      IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 
     745         ! 
     746         SELECT CASE ( jpni ) 
     747         CASE ( 1 )     ;    
     748             DO ii = 1 , num_fields   
     749                       CALL lbc_nfd      ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) )   ! only 1 northern proc, no mpp 
     750             END DO 
     751         CASE DEFAULT   ;   CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields )   ! for all northern procs. 
     752         END SELECT 
     753         ! 
     754      ENDIF 
     755        ! 
    746756       
    747757      DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 
     
    16891699   END SUBROUTINE mppmax_real 
    16901700 
     1701   SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom  ) 
     1702      !!---------------------------------------------------------------------- 
     1703      !!                  ***  routine mppmax_real  *** 
     1704      !! 
     1705      !! ** Purpose :   Maximum 
     1706      !! 
     1707      !!---------------------------------------------------------------------- 
     1708      REAL(wp), DIMENSION(:) ,  INTENT(inout)           ::   ptab   ! ??? 
     1709      INTEGER , INTENT(in   )           ::   NUM 
     1710      INTEGER , INTENT(in   ), OPTIONAL ::   kcom   ! ??? 
     1711      !! 
     1712      INTEGER  ::   ierror, localcomm 
     1713      REAL(wp) , POINTER , DIMENSION(:) ::   zwork 
     1714      !!---------------------------------------------------------------------- 
     1715      ! 
     1716      CALL wrk_alloc(NUM , zwork) 
     1717      localcomm = mpi_comm_opa 
     1718      IF( PRESENT(kcom) )   localcomm = kcom 
     1719      ! 
     1720      CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 
     1721      ptab = zwork 
     1722      CALL wrk_dealloc(NUM , zwork) 
     1723      ! 
     1724   END SUBROUTINE mppmax_real_multiple 
     1725 
    16911726 
    16921727   SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
     
    25832618   END SUBROUTINE mpp_lbc_north_2d 
    25842619 
     2620   SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 
     2621      !!--------------------------------------------------------------------- 
     2622      !!                   ***  routine mpp_lbc_north_2d  *** 
     2623      !! 
     2624      !! ** Purpose :   Ensure proper north fold horizontal bondary condition 
     2625      !!              in mpp configuration in case of jpn1 > 1 
     2626      !!              (for multiple 2d arrays ) 
     2627      !! 
     2628      !! ** Method  :   North fold condition and mpp with more than one proc 
     2629      !!              in i-direction require a specific treatment. We gather 
     2630      !!              the 4 northern lines of the global domain on 1 processor 
     2631      !!              and apply lbc north-fold on this sub array. Then we 
     2632      !!              scatter the north fold array back to the processors. 
     2633      !! 
     2634      !!---------------------------------------------------------------------- 
     2635      INTEGER ,  INTENT (in   ) ::   num_fields  ! number of variables contained in pt2d 
     2636      TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 
     2637      CHARACTER(len=1), DIMENSION(:), INTENT(in   ) ::   cd_type   ! nature of pt2d grid-points 
     2638      !                                                          !   = T ,  U , V , F or W  gridpoints 
     2639      REAL(wp), DIMENSION(:), INTENT(in   ) ::   psgn      ! = -1. the sign change across the north fold  
     2640      !!                                                             ! =  1. , the sign is kept 
     2641      INTEGER ::   ji, jj, jr, jk 
     2642      INTEGER ::   ierr, itaille, ildi, ilei, iilb 
     2643      INTEGER ::   ijpj, ijpjm1, ij, iproc 
     2644      INTEGER, DIMENSION (jpmaxngh)      ::   ml_req_nf          !for mpi_isend when avoiding mpi_allgather 
     2645      INTEGER                            ::   ml_err             ! for mpi_isend when avoiding mpi_allgather 
     2646      INTEGER, DIMENSION(MPI_STATUS_SIZE)::   ml_stat            ! for mpi_isend when avoiding mpi_allgather 
     2647      !                                                              ! Workspace for message transfers avoiding mpi_allgather 
     2648      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztab 
     2649      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: znorthloc, zfoldwk 
     2650      REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE   :: znorthgloio 
     2651      REAL(wp), DIMENSION(:,:,:)  , ALLOCATABLE   :: ztabl, ztabr 
     2652      INTEGER :: istatus(mpi_status_size) 
     2653      INTEGER :: iflag 
     2654      !!---------------------------------------------------------------------- 
     2655      ! 
     2656      ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields),   &  
     2657            &   znorthgloio(jpi,4,num_fields,jpni) )   ! expanded to 3 dimensions 
     2658      ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 
     2659      ! 
     2660      ijpj   = 4 
     2661      ijpjm1 = 3 
     2662      ! 
     2663       
     2664      DO jk = 1, num_fields 
     2665         DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d (for every variable) 
     2666            ij = jj - nlcj + ijpj 
     2667            znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 
     2668         END DO 
     2669      END DO 
     2670      !                                     ! Build in procs of ncomm_north the znorthgloio 
     2671      itaille = jpi * ijpj 
     2672                                                                   
     2673      IF ( l_north_nogather ) THEN 
     2674         ! 
     2675         ! Avoid the use of mpi_allgather by exchanging only with the processes already identified  
     2676         ! (in nemo_northcomms) as being  involved in this process' northern boundary exchange 
     2677         ! 
     2678         ztabr(:,:,:) = 0 
     2679         ztabl(:,:,:) = 0 
     2680 
     2681         DO jk = 1, num_fields 
     2682            DO jj = nlcj-ijpj+1, nlcj          ! First put local values into the global array 
     2683               ij = jj - nlcj + ijpj 
     2684               DO ji = nfsloop, nfeloop 
     2685                  ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 
     2686               END DO 
     2687            END DO 
     2688         END DO 
     2689 
     2690         DO jr = 1,nsndto 
     2691            IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2692               CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 
     2693            ENDIF 
     2694         END DO 
     2695         DO jr = 1,nsndto 
     2696            iproc = nfipproc(isendto(jr),jpnj) 
     2697            IF(iproc .ne. -1) THEN 
     2698               ilei = nleit (iproc+1) 
     2699               ildi = nldit (iproc+1) 
     2700               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 
     2701            ENDIF 
     2702            IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 
     2703              CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 
     2704              DO jk = 1 , num_fields 
     2705                 DO jj = 1, ijpj 
     2706                    DO ji = ildi, ilei 
     2707                       ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk)       ! Modified to 3D 
     2708                    END DO 
     2709                 END DO 
     2710              END DO 
     2711            ELSE IF (iproc .eq. (narea-1)) THEN 
     2712              DO jk = 1, num_fields 
     2713                 DO jj = 1, ijpj 
     2714                    DO ji = ildi, ilei 
     2715                          ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj)       ! Modified to 3D 
     2716                    END DO 
     2717                 END DO 
     2718              END DO 
     2719            ENDIF 
     2720         END DO 
     2721         IF (l_isend) THEN 
     2722            DO jr = 1,nsndto 
     2723               IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 
     2724                  CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 
     2725               ENDIF 
     2726            END DO 
     2727         ENDIF 
     2728         ! 
     2729         DO ji = 1, num_fields     ! Loop to manage 3D variables 
     2730            CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) )  ! North fold boundary condition 
     2731         END DO 
     2732         ! 
     2733         DO jk = 1, num_fields 
     2734            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2735               ij = jj - nlcj + ijpj 
     2736               DO ji = 1, nlci 
     2737                  pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk)       ! Modified to 3D 
     2738               END DO 
     2739            END DO 
     2740         END DO 
     2741          
     2742         ! 
     2743      ELSE 
     2744         ! 
     2745         CALL MPI_ALLGATHER( znorthloc  , itaille*num_fields, MPI_DOUBLE_PRECISION,        & 
     2746            &                znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 
     2747         ! 
     2748         ztab(:,:,:) = 0.e0 
     2749         DO jk = 1, num_fields 
     2750            DO jr = 1, ndim_rank_north            ! recover the global north array 
     2751               iproc = nrank_north(jr) + 1 
     2752               ildi = nldit (iproc) 
     2753               ilei = nleit (iproc) 
     2754               iilb = nimppt(iproc) 
     2755               DO jj = 1, ijpj 
     2756                  DO ji = ildi, ilei 
     2757                     ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 
     2758                  END DO 
     2759               END DO 
     2760            END DO 
     2761         END DO 
     2762          
     2763         DO ji = 1, num_fields 
     2764            CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) )   ! North fold boundary condition 
     2765         END DO 
     2766         ! 
     2767         DO jk = 1, num_fields 
     2768            DO jj = nlcj-ijpj+1, nlcj             ! Scatter back to pt2d 
     2769               ij = jj - nlcj + ijpj 
     2770               DO ji = 1, nlci 
     2771                  pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 
     2772               END DO 
     2773            END DO 
     2774         END DO 
     2775         ! 
     2776         ! 
     2777      ENDIF 
     2778      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 
     2779      DEALLOCATE( ztabl, ztabr ) 
     2780      ! 
     2781   END SUBROUTINE mpp_lbc_north_2d_multiple 
    25852782 
    25862783   SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/LDF/ldfeiv.F90

    r6427 r7487  
    157157         END DO 
    158158      ENDIF 
     159 
     160      ! ORCA R1: Take the minimum between aeiw  and aeiv0 
     161      IF( cp_cfg == "orca" .AND. jp_cfg == 1 ) THEN 
     162         DO jj = 2, jpjm1 
     163            DO ji = fs_2, fs_jpim1   ! vector opt. 
     164               aeiw(ji,jj) = MIN( aeiw(ji,jj), aeiv0 ) 
     165            END DO 
     166         END DO 
     167      ENDIF 
     168 
    159169      CALL lbc_lnk( aeiw, 'W', 1. )      ! lateral boundary condition on aeiw  
    160170 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6427 r7487  
    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) 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r7009 r7487  
    13351335      !!             ***  ROUTINE sbc_cpl_ice_flx  *** 
    13361336      !! 
    1337       !! ** Purpose :   provide the heat and freshwater fluxes of the  
    1338       !!              ocean-ice system. 
     1337      !! ** Purpose :   provide the heat and freshwater fluxes of the ocean-ice system 
    13391338      !! 
    13401339      !! ** Method  :   transform the fields received from the atmosphere into 
    13411340      !!             surface heat and fresh water boundary condition for the  
    13421341      !!             ice-ocean system. The following fields are provided: 
    1343       !!              * total non solar, solar and freshwater fluxes (qns_tot,  
     1342      !!               * total non solar, solar and freshwater fluxes (qns_tot,  
    13441343      !!             qsr_tot and emp_tot) (total means weighted ice-ocean flux) 
    13451344      !!             NB: emp_tot include runoffs and calving. 
    1346       !!              * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
     1345      !!               * fluxes over ice (qns_ice, qsr_ice, emp_ice) where 
    13471346      !!             emp_ice = sublimation - solid precipitation as liquid 
    13481347      !!             precipitation are re-routed directly to the ocean and  
    1349       !!             runoffs and calving directly enter the ocean. 
    1350       !!              * solid precipitation (sprecip), used to add to qns_tot  
     1348      !!             calving directly enter the ocean (runoffs are read but included in trasbc.F90) 
     1349      !!               * solid precipitation (sprecip), used to add to qns_tot  
    13511350      !!             the heat lost associated to melting solid precipitation 
    13521351      !!             over the ocean fraction. 
    1353       !!       ===>> CAUTION here this changes the net heat flux received from 
    1354       !!             the atmosphere 
    1355       !! 
    1356       !!                  - the fluxes have been separated from the stress as 
    1357       !!                 (a) they are updated at each ice time step compare to 
    1358       !!                 an update at each coupled time step for the stress, and 
    1359       !!                 (b) the conservative computation of the fluxes over the 
    1360       !!                 sea-ice area requires the knowledge of the ice fraction 
    1361       !!                 after the ice advection and before the ice thermodynamics, 
    1362       !!                 so that the stress is updated before the ice dynamics 
    1363       !!                 while the fluxes are updated after it. 
     1352      !!               * heat content of rain, snow and evap can also be provided, 
     1353      !!             otherwise heat flux associated with these mass flux are 
     1354      !!             guessed (qemp_oce, qemp_ice) 
     1355      !! 
     1356      !!             - the fluxes have been separated from the stress as 
     1357      !!               (a) they are updated at each ice time step compare to 
     1358      !!               an update at each coupled time step for the stress, and 
     1359      !!               (b) the conservative computation of the fluxes over the 
     1360      !!               sea-ice area requires the knowledge of the ice fraction 
     1361      !!               after the ice advection and before the ice thermodynamics, 
     1362      !!               so that the stress is updated before the ice dynamics 
     1363      !!               while the fluxes are updated after it. 
     1364      !! 
     1365      !! ** Details 
     1366      !!             qns_tot = pfrld * qns_oce + ( 1 - pfrld ) * qns_ice   => provided 
     1367      !!                     + qemp_oce + qemp_ice                         => recalculated and added up to qns 
     1368      !! 
     1369      !!             qsr_tot = pfrld * qsr_oce + ( 1 - pfrld ) * qsr_ice   => provided 
     1370      !! 
     1371      !!             emp_tot = emp_oce + emp_ice                           => calving is provided and added to emp_tot (and emp_oce) 
     1372      !!                                                                      river runoff (rnf) is provided but not included here 
    13641373      !! 
    13651374      !! ** Action  :   update at each nf_ice time step: 
    13661375      !!                   qns_tot, qsr_tot  non-solar and solar total heat fluxes 
    13671376      !!                   qns_ice, qsr_ice  non-solar and solar heat fluxes over the ice 
    1368       !!                   emp_tot            total evaporation - precipitation(liquid and solid) (-runoff)(-calving) 
    1369       !!                   emp_ice            ice sublimation - solid precipitation over the ice 
    1370       !!                   dqns_ice           d(non-solar heat flux)/d(Temperature) over the ice 
    1371       !!                   sprecip             solid precipitation over the ocean   
     1377      !!                   emp_tot           total evaporation - precipitation(liquid and solid) (-calving) 
     1378      !!                   emp_ice           ice sublimation - solid precipitation over the ice 
     1379      !!                   dqns_ice          d(non-solar heat flux)/d(Temperature) over the ice 
     1380      !!                   sprecip           solid precipitation over the ocean   
    13721381      !!---------------------------------------------------------------------- 
    13731382      REAL(wp), INTENT(in   ), DIMENSION(:,:)   ::   p_frld     ! lead fraction                [0 to 1] 
     
    13791388      INTEGER ::   jl         ! dummy loop index 
    13801389      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk, zsnw 
    1381       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice 
     1390      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice 
    13821391      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
    13831392      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
     
    13871396      ! 
    13881397      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
    1389       CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 
     1398      CALL wrk_alloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    13901399      CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    13911400      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
     
    13961405      ! 
    13971406      !                                                      ! ========================= ! 
    1398       !                                                      !    freshwater budget      !   (emp) 
     1407      !                                                      !    freshwater budget      !   (emp_tot) 
    13991408      !                                                      ! ========================= ! 
    14001409      ! 
    1401       !                                                           ! total Precipitation - total Evaporation (emp_tot) 
    1402       !                                                           ! solid precipitation - sublimation       (emp_ice) 
    1403       !                                                           ! solid Precipitation                     (sprecip) 
    1404       !                                                           ! liquid + solid Precipitation            (tprecip) 
     1410      !                                                           ! solid Precipitation                                (sprecip) 
     1411      !                                                           ! liquid + solid Precipitation                       (tprecip) 
     1412      !                                                           ! total Evaporation - total Precipitation            (emp_tot) 
     1413      !                                                           ! sublimation - solid precipitation (cell average)   (emp_ice) 
    14051414      SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) 
    1406       CASE( 'conservative'  )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
    1407          zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
    1408          ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
    1409          zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
    1410          zemp_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) 
    1411          CALL iom_put( 'rain'         , frcv(jpr_rain)%z3(:,:,1) * tmask(:,:,1)      )   ! liquid precipitation  
    1412          CALL iom_put( 'rain_ao_cea'  , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1)      )   ! liquid precipitation  
     1415      CASE( 'conservative' )   ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp 
     1416         zsprecip(:,:) =   frcv(jpr_snow)%z3(:,:,1)                  ! May need to ensure positive here 
     1417         ztprecip(:,:) =   frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:)  ! May need to ensure positive here 
     1418         zemp_tot(:,:) =   frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) 
     1419         zemp_ice(:,:) = ( frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_snow)%z3(:,:,1) ) * zicefr(:,:) 
     1420         IF( iom_use('precip') )          & 
     1421            &  CALL iom_put( 'precip'       ,   frcv(jpr_rain)%z3(:,:,1) + frcv(jpr_snow)%z3(:,:,1)                              )  ! total  precipitation 
     1422         IF( iom_use('rain') )            & 
     1423            &  CALL iom_put( 'rain'         ,   frcv(jpr_rain)%z3(:,:,1)                                                         )  ! liquid precipitation  
     1424         IF( iom_use('rain_ao_cea') )   & 
     1425            &  CALL iom_put( 'rain_ao_cea'  , frcv(jpr_rain)%z3(:,:,1)* p_frld(:,:) * tmask(:,:,1)      )   ! liquid precipitation  
    14131426         IF( iom_use('hflx_rain_cea') )   & 
    14141427            CALL iom_put( 'hflx_rain_cea', frcv(jpr_rain)%z3(:,:,1) * zcptn(:,:) * tmask(:,:,1))   ! heat flux from liq. precip.  
     
    14231436      CASE( 'oce and ice'   )   ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp 
    14241437         zemp_tot(:,:) = p_frld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + zicefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) 
    1425          zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) 
     1438         zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * zicefr(:,:) 
    14261439         zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) 
    14271440         ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) 
     
    14291442 
    14301443#if defined key_lim3 
    1431       ! zsnw = snow percentage over ice after wind blowing 
    1432       zsnw(:,:) = 0._wp 
    1433       CALL lim_thd_snwblow( p_frld, zsnw ) 
     1444      ! zsnw = snow fraction over ice after wind blowing 
     1445      zsnw(:,:) = 0._wp  ;  CALL lim_thd_snwblow( p_frld, zsnw ) 
    14341446       
    1435       ! --- evaporation (kg/m2/s) --- ! 
     1447      ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! 
     1448      zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( zicefr(:,:) - zsnw(:,:) )  ! emp_ice = A * sublimation - zsnw * sprecip 
     1449      zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:)                                ! emp_oce = emp_tot - emp_ice 
     1450 
     1451      ! --- evaporation over ocean (used later for qemp) --- ! 
     1452      zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) 
     1453 
     1454      ! --- evaporation over ice (kg/m2/s) --- ! 
    14361455      zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
    14371456      ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
     
    14391458      zdevap_ice(:,:) = 0._wp 
    14401459       
    1441       ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 
    1442       zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 
    1443       zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw)           
    1444  
    1445       ! Sublimation over sea-ice (cell average) 
    1446       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) 
    1447       ! runoffs and calving (put in emp_tot) 
     1460      ! --- runoffs (included in emp later on) --- ! 
    14481461      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     1462 
     1463      ! --- calving (put in emp_tot and emp_oce) --- ! 
    14491464      IF( srcv(jpr_cal)%laction ) THEN  
    14501465         zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
     1466         zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    14511467         CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    14521468      ENDIF 
     
    14741490      ENDIF 
    14751491 
    1476                                      CALL iom_put( 'snowpre'    , sprecip                         )  ! Snow 
    1477       IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw ) )  ! Snow over ice-free ocean  (cell average) 
    1478       IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw   )  ! Snow over sea-ice         (cell average)     
     1492      IF( iom_use('subl_ai_cea') )   CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:)         )  ! Sublimation over sea-ice (cell average) 
     1493                                     CALL iom_put( 'snowpre'    , sprecip(:,:)                         )  ! Snow 
     1494      IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw(:,:) ) )  ! Snow over ice-free ocean  (cell average) 
     1495      IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw(:,:)   )  ! Snow over sea-ice         (cell average) 
    14791496#else 
    1480       ! Sublimation over sea-ice (cell average) 
    1481       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) 
    14821497! runoffs and calving (put in emp_tot) 
    14831498      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
     
    15011516      ENDIF 
    15021517 
    1503          CALL iom_put( 'snowpre'    , sprecip * tmask(:,:,1)                 )   ! Snow 
    1504       IF( iom_use('snow_ao_cea') )   & 
    1505          CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) * tmask(:,:,1)       )   ! Snow        over ice-free ocean  (cell average) 
    1506       IF( iom_use('snow_ai_cea') )   & 
    1507          CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) * tmask(:,:,1)       )   ! Snow        over sea-ice         (cell average) 
     1518      IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )  ! Sublimation over sea-ice (cell average) 
     1519                                    CALL iom_put( 'snowpre'    , sprecip(:,:)               )   ! Snow 
     1520      IF( iom_use('snow_ao_cea') )  CALL iom_put( 'snow_ao_cea', sprecip(:,:) * p_frld(:,:) )   ! Snow over ice-free ocean  (cell average) 
     1521      IF( iom_use('snow_ai_cea') )  CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:) )   ! Snow over sea-ice         (cell average) 
    15081522#endif 
    15091523 
     
    15111525      SELECT CASE( TRIM( sn_rcv_qns%cldes ) )                !   non solar heat fluxes   !   (qns) 
    15121526      !                                                      ! ========================= ! 
    1513       CASE( 'oce only' )                                     ! the required field is directly provided 
    1514          zqns_tot(:,:  ) = frcv(jpr_qnsoce)%z3(:,:,1) 
    1515       CASE( 'conservative' )                                      ! the required fields are directly provided 
    1516          zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
     1527      CASE( 'oce only' )         ! the required field is directly provided 
     1528         zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) 
     1529      CASE( 'conservative' )     ! the required fields are directly provided 
     1530         zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) 
    15171531         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    15181532            zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) 
    15191533         ELSE 
    1520             ! Set all category values equal for the moment 
    15211534            DO jl=1,jpl 
    1522                zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) 
     1535               zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal 
    15231536            ENDDO 
    15241537         ENDIF 
    1525       CASE( 'oce and ice' )       ! the total flux is computed from ocean and ice fluxes 
    1526          zqns_tot(:,:  ) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
     1538      CASE( 'oce and ice' )      ! the total flux is computed from ocean and ice fluxes 
     1539         zqns_tot(:,:) =  p_frld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) 
    15271540         IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN 
    15281541            DO jl=1,jpl 
     
    15311544            ENDDO 
    15321545         ELSE 
    1533             qns_tot(:,:   ) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     1546            qns_tot(:,:) = qns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
    15341547            DO jl=1,jpl 
    15351548               zqns_tot(:,:   ) = zqns_tot(:,:) + zicefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) 
     
    15371550            ENDDO 
    15381551         ENDIF 
    1539       CASE( 'mixed oce-ice' )     ! the ice flux is cumputed from the total flux, the SST and ice informations 
     1552      CASE( 'mixed oce-ice' )    ! the ice flux is cumputed from the total flux, the SST and ice informations 
    15401553! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** 
    15411554         zqns_tot(:,:  ) = frcv(jpr_qnsmix)%z3(:,:,1) 
    15421555         zqns_ice(:,:,1) = frcv(jpr_qnsmix)%z3(:,:,1)    & 
    15431556            &            + frcv(jpr_dqnsdt)%z3(:,:,1) * ( pist(:,:,1) - ( (rt0 + psst(:,:  ) ) * p_frld(:,:)   & 
    1544             &                                                   +          pist(:,:,1)  * zicefr(:,:) ) ) 
     1557            &                                           + pist(:,:,1) * zicefr(:,:) ) ) 
    15451558      END SELECT 
    15461559!!gm 
     
    15521565!! similar job should be done for snow and precipitation temperature 
    15531566      !                                      
    1554       IF( srcv(jpr_cal)%laction ) THEN                            ! Iceberg melting  
    1555          ztmp(:,:) = frcv(jpr_cal)%z3(:,:,1) * lfus               ! add the latent heat of iceberg melting  
    1556          zqns_tot(:,:) = zqns_tot(:,:) - ztmp(:,:) 
    1557          IF( iom_use('hflx_cal_cea') )   & 
    1558             CALL iom_put( 'hflx_cal_cea', ztmp + frcv(jpr_cal)%z3(:,:,1) * zcptn(:,:) )   ! heat flux from calving 
    1559       ENDIF 
    1560  
    1561       ztmp(:,:) = p_frld(:,:) * zsprecip(:,:) * lfus 
    1562       IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
     1567      IF( srcv(jpr_cal)%laction ) THEN   ! Iceberg melting  
     1568         zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * lfus  ! add the latent heat of iceberg melting 
     1569                                                                         ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean 
     1570         IF( iom_use('hflx_cal_cea') )   CALL iom_put( 'hflx_cal_cea', - frcv(jpr_cal)%z3(:,:,1) * lfus )   ! heat flux from calving 
     1571      ENDIF 
    15631572 
    15641573#if defined key_lim3       
    1565       ! --- evaporation --- ! 
    1566       zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
    1567  
    15681574      ! --- non solar flux over ocean --- ! 
    15691575      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
     
    15721578 
    15731579      ! --- heat flux associated with emp (W/m2) --- ! 
    1574       zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    1575          &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    1576          &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
     1580      zqemp_oce(:,:) = -  zevap_oce(:,:)                                      *   zcptn(:,:)   &       ! evap 
     1581         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &       ! liquid precip 
     1582         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus )  ! solid precip over ocean + snow melting 
    15771583!      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    15781584!         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    15791585      zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
    1580                                                                                                        ! qevap_ice=0 since we consider Tice=0°C 
     1586                                                                                                       ! qevap_ice=0 since we consider Tice=0degC 
    15811587       
    1582       ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
     1588      ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15831589      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15841590 
    15851591      ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
    15861592      DO jl = 1, jpl 
    1587          zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0°C 
     1593         zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0degC 
    15881594      END DO 
    15891595 
     
    16111617         qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
    16121618      ENDIF 
     1619 
     1620      ! some more outputs 
     1621      IF( iom_use('hflx_snow_cea') )    CALL iom_put('hflx_snow_cea',   sprecip(:,:) * ( zcptn(:,:) - Lfus ) )                       ! heat flux from snow (cell average) 
     1622      IF( iom_use('hflx_rain_cea') )    CALL iom_put('hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * zcptn(:,:) )                 ! heat flux from rain (cell average) 
     1623      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) 
     1624      IF( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea',sprecip(:,:) * ( zcptn(:,:) - Lfus ) * zsnw(:,:) )           ! heat flux from snow (cell average) 
     1625 
    16131626#else 
    16141627      ! clem: this formulation is certainly wrong... but better than it was... 
     
    16161629         &          - ztmp(:,:)                           &            ! remove the latent heat flux of solid precip. melting 
    16171630         &          - (  zemp_tot(:,:)                    &            ! remove the heat content of mass flux (assumed to be at SST) 
    1618          &             - zemp_ice(:,:) * zicefr(:,:)  ) * zcptn(:,:)  
     1631         &             - zemp_ice(:,:) ) * zcptn(:,:)  
    16191632 
    16201633     IF( ln_mixcpl ) THEN 
     
    17361749 
    17371750      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
    1738       CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 
     1751      CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap_oce, zevap_ice, zdevap_ice ) 
    17391752      CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    17401753      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r6427 r7487  
    229229         CALL lim_sbc_flx( kt )                     ! Update surface ocean mass, heat and salt fluxes 
    230230         ! 
    231          IF(ln_limdiaout) CALL lim_diahsb           ! Diagnostics and outputs  
     231         IF(ln_limdiaout) CALL lim_diahsb( kt )     ! Diagnostics and outputs  
    232232         ! 
    233233         CALL lim_wri( 1 )                          ! Ice outputs  
     
    310310         numit = nit000 - 1 
    311311      ENDIF 
    312       CALL lim_var_agg(1) 
     312      CALL lim_var_agg(2) 
    313313      CALL lim_var_glo2eqv 
    314314      ! 
    315315      CALL lim_sbc_init                 ! ice surface boundary condition    
     316      ! 
     317      IF( ln_limdiaout) CALL lim_diahsb_init  ! initialization for diags 
    316318      ! 
    317319      fr_i(:,:)     = at_i(:,:)         ! initialisation of sea-ice fraction 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r6427 r7487  
    340340         emp_b(:,:) = emp(:,:) 
    341341         sfx_b(:,:) = sfx(:,:) 
     342         IF ( ln_rnf ) THEN 
     343            rnf_b    (:,:  ) = rnf    (:,:  ) 
     344            rnf_tsc_b(:,:,:) = rnf_tsc(:,:,:) 
     345         ENDIF 
    342346      ENDIF 
    343347      !                                            ! ---------------------------------------- ! 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r6427 r7487  
    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/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6427 r7487  
    10181018         DO jj = 1, jpj 
    10191019            DO ji = 1, jpi 
    1020                zs= SQRT( ABS( psal(ji,jj) ) * r1_S0 )           ! square root salinity 
     1020               zs= SQRT( ABS( psal(ji,jj) ) / 35.16504_wp )           ! square root salinity 
    10211021               ptf(ji,jj) = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10221022                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     
    10661066      CASE ( -1, 1 )                !==  CT,SA (TEOS-10 formulation) ==! 
    10671067         ! 
    1068          zs  = SQRT( ABS( psal ) * r1_S0 )           ! square root salinity 
     1068         zs  = SQRT( ABS( psal ) / 35.16504_wp )           ! square root salinity 
    10691069         ptf = ((((1.46873e-03_wp*zs-9.64972e-03_wp)*zs+2.28348e-02_wp)*zs & 
    10701070                  &          - 3.12775e-02_wp)*zs+2.07679e-02_wp)*zs-5.87701e-02_wp 
     
    12561256            WRITE(numout,*) '             model does not use Conservative Temperature' 
    12571257         ENDIF 
     1258      ENDIF 
     1259      ! 
     1260      ! Consistency check on ln_useCT and nn_eos 
     1261      IF ((nn_eos .EQ. -1) .AND. (.NOT. ln_useCT)) THEN 
     1262         CALL ctl_stop("ln_useCT should be set to True if using TEOS-10 (nn_eos=-1)") 
     1263      ELSE IF ((nn_eos .NE. -1) .AND. (ln_useCT)) THEN 
     1264         CALL ctl_stop("ln_useCT should be set to False if using TEOS-80 or simplified equation of state (nn_eos=0 or nn_eos=1)") 
    12581265      ENDIF 
    12591266      ! 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r6910 r7487  
    184184            DO jj = 2, jpjm1 
    185185               DO ji = fs_2, fs_jpim1   ! vector opt. 
    186                   zbtr = 1. / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    187186                  ! total intermediate advective trends 
    188                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    189                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    190                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     187                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     188                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     189                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    191190                  ! update and guess with monotonic sheme 
    192                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra  * tmask(ji,jj,jk) 
    193                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     191                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     192                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    194193               END DO 
    195194            END DO 
     
    454453            DO jj = 2, jpjm1 
    455454               DO ji = fs_2, fs_jpim1   ! vector opt. 
    456                   zbtr = 1._wp / ( e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,jk) ) 
    457455                  ! total intermediate advective trends 
    458                   ztra = - zbtr * (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
    459                      &             + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
    460                      &             + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) 
     456                  ztra = - (  zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   & 
     457                     &      + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  )   & 
     458                     &      + zwz(ji,jj,jk) - zwz(ji  ,jj  ,jk+1) ) / e1e2t(ji,jj) 
    461459                  ! update and guess with monotonic sheme 
    462                   pta(ji,jj,jk,jn) =   pta(ji,jj,jk,jn)         + ztra 
    463                   zwi(ji,jj,jk)    = ( ptb(ji,jj,jk,jn) + z2dtt * ztra ) * tmask(ji,jj,jk) 
     460                  pta(ji,jj,jk,jn) =                       pta(ji,jj,jk,jn) +         ztra   / fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) 
     461                  zwi(ji,jj,jk)    = ( fse3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + z2dtt * ztra ) / fse3t_a(ji,jj,jk) * tmask(ji,jj,jk) 
    464462               END DO 
    465463            END DO 
     
    479477         ! -------------------------------------------------- 
    480478         ! antidiffusive flux on i and j 
    481  
    482  
     479         ! 
    483480         DO jk = 1, jpkm1 
    484  
     481            ! 
    485482            DO jj = 1, jpjm1 
    486483               DO ji = 1, fs_jpim1   ! vector opt. 
     
    513510         ! 
    514511         ztrs(:,:,:,1) = ptb(:,:,:,jn) 
     512         ztrs(:,:,1,2) = ptb(:,:,1,jn) 
     513         ztrs(:,:,1,3) = ptb(:,:,1,jn) 
    515514         zwzts(:,:,:) = 0._wp 
    516515 
     
    614613   END SUBROUTINE tra_adv_tvd_zts 
    615614 
     615 
    616616   SUBROUTINE nonosc( pbef, paa, pbb, pcc, paft, p2dt ) 
    617617      !!--------------------------------------------------------------------- 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r6427 r7487  
    158158         ELSE                                         ! No restart or restart not found: Euler forward time stepping 
    159159            zfact = 1._wp 
     160            sbc_tsc(:,:,:) = 0._wp 
    160161            sbc_tsc_b(:,:,:) = 0._wp 
    161162         ENDIF 
     
    278279         END DO   
    279280      ENDIF 
    280   
     281 
     282      IF( iom_use('rnf_x_sst') )   CALL iom_put( "rnf_x_sst", rnf*tsn(:,:,1,jp_tem) )   ! runoff term on sst 
     283      IF( iom_use('rnf_x_sss') )   CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) )   ! runoff term on sss 
     284 
    281285      IF( l_trdtra )   THEN                      ! send trends for further diagnostics 
    282286         ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfric.F90

    r6427 r7487  
    162162                  &                               + avmv(ji,jj,jk) + avmv(ji,jj-1,jk)  )   & 
    163163                  &          + avtb(jk) * tmask(ji,jj,jk) 
    164                !                                            ! Add the background coefficient on eddy viscosity 
     164            END DO 
     165         END DO 
     166         DO jj = 2, jpjm1                                   ! Add the background coefficient on eddy viscosity 
     167            DO ji = 2, jpim1 
    165168               avmu(ji,jj,jk) = avmu(ji,jj,jk) + avmb(jk) * umask(ji,jj,jk) 
    166169               avmv(ji,jj,jk) = avmv(ji,jj,jk) + avmb(jk) * vmask(ji,jj,jk) 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6672 r7487  
    338338      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    339339      ! 
     340      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
     341 
    340342      IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
    341343      IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
     
    352354      ENDIF 
    353355#endif 
    354       IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    355       IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
     356      IF( lk_diaobs        )   CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    356357 
    357358      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90

    r6427 r7487  
    3131   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   sio3eq   ! chemistry of Si 
    3232   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   fekeq    ! chemistry of Fe 
    33    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ::   chemc    ! Solubilities of O2 and CO2 
     33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemc    ! Solubilities of O2 and CO2 
    3434   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2   ! Solubilities of O2 and CO2 
     35   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   tempis   ! In situ temperature 
    3536 
    3637   REAL(wp), PUBLIC ::   atcox  = 0.20946         ! units atm 
     
    3940   REAL(wp) ::   o2atm  = 1. / ( 1000. * 0.20946 )   
    4041 
    41    REAL(wp) ::   akcc1  = -171.9065       ! coeff. for apparent solubility equilibrium 
    42    REAL(wp) ::   akcc2  =   -0.077993     ! Millero et al. 1995 from Mucci 1983 
    43    REAL(wp) ::   akcc3  = 2839.319         
    44    REAL(wp) ::   akcc4  =   71.595         
    45    REAL(wp) ::   akcc5  =   -0.77712       
    46    REAL(wp) ::   akcc6  =    0.00284263    
    47    REAL(wp) ::   akcc7  =  178.34         
    48    REAL(wp) ::   akcc8  =   -0.07711      
    49    REAL(wp) ::   akcc9  =    0.0041249    
    50  
    51    REAL(wp) ::   rgas   = 83.143         ! universal gas constants 
     42   REAL(wp) ::   rgas   = 83.14472       ! universal gas constants 
    5243   REAL(wp) ::   oxyco  = 1. / 22.4144   ! converts from liters of an ideal gas to moles 
    5344 
    5445   REAL(wp) ::   bor1   = 0.00023        ! borat constants 
    5546   REAL(wp) ::   bor2   = 1. / 10.82 
    56  
    57    REAL(wp) ::   ca0    = -162.8301      ! WEISS & PRICE 1980, units mol/(kg atm) 
    58    REAL(wp) ::   ca1    =  218.2968 
    59    REAL(wp) ::   ca2    =   90.9241 
    60    REAL(wp) ::   ca3    =   -1.47696 
    61    REAL(wp) ::   ca4    =    0.025695 
    62    REAL(wp) ::   ca5    =   -0.025225 
    63    REAL(wp) ::   ca6    =    0.0049867 
    64  
    65    REAL(wp) ::   c10    = -3670.7        ! Coeff. for 1. dissoc. of carbonic acid (Edmond and Gieskes, 1970)    
    66    REAL(wp) ::   c11    =    62.008      
    67    REAL(wp) ::   c12    =    -9.7944     
    68    REAL(wp) ::   c13    =     0.0118      
    69    REAL(wp) ::   c14    =    -0.000116 
    70  
    71    REAL(wp) ::   c20    = -1394.7       ! coeff. for 2. dissoc. of carbonic acid (Millero, 1995)    
    72    REAL(wp) ::   c21    =    -4.777    
    73    REAL(wp) ::   c22    =     0.0184    
    74    REAL(wp) ::   c23    =    -0.000118 
    7547 
    7648   REAL(wp) ::   st1    =      0.14     ! constants for calculate concentrations for sulfate 
     
    146118      REAL(wp) ::   ztgg , ztgg2, ztgg3 , ztgg4 , ztgg5 
    147119      REAL(wp) ::   zpres, ztc  , zcl   , zcpexp, zoxy  , zcpexp2 
    148       REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1 
    149       REAL(wp) ::   zis  , zis2 , zsal15, zisqrt 
     120      REAL(wp) ::   zsqrt, ztr  , zlogt , zcek1, zc1, zplat 
     121      REAL(wp) ::   zis  , zis2 , zsal15, zisqrt, za1  , za2 
    150122      REAL(wp) ::   zckb , zck1 , zck2  , zckw  , zak1 , zak2  , zakb , zaksp0, zakw 
    151123      REAL(wp) ::   zst  , zft  , zcks  , zckf  , zaksp1 
     
    154126      IF( nn_timing == 1 )  CALL timing_start('p4z_che') 
    155127      ! 
     128      ! Computations of chemical constants require in situ temperature 
     129      ! Here a quite simple formulation is used to convert  
     130      ! potential temperature to in situ temperature. The errors is less than  
     131      ! 0.04°C relative to an exact computation 
     132      ! --------------------------------------------------------------------- 
     133      DO jk = 1, jpk 
     134         DO jj = 1, jpj 
     135            DO ji = 1, jpi 
     136               zpres = fsdept(ji,jj,jk) / 1000. 
     137               za1 = 0.04 * ( 1.0 + 0.185 * tsn(ji,jj,jk,jp_tem) + 0.035 * (tsn(ji,jj,jk,jp_sal) - 35.0) ) 
     138               za2 = 0.0075 * ( 1.0 - tsn(ji,jj,jk,jp_tem) / 30.0 ) 
     139               tempis(ji,jj,jk) = tsn(ji,jj,jk,jp_tem) - za1 * zpres + za2 * zpres**2 
     140            END DO 
     141         END DO 
     142      END DO 
     143      ! 
    156144      ! CHEMICAL CONSTANTS - SURFACE LAYER 
    157145      ! ---------------------------------- 
     
    161149         DO ji = 1, jpi 
    162150            !                             ! SET ABSOLUTE TEMPERATURE 
    163             ztkel = tsn(ji,jj,1,jp_tem) + 273.15 
     151            ztkel = tempis(ji,jj,1) + 273.15 
    164152            zt    = ztkel * 0.01 
    165153            zt2   = zt * zt 
     
    169157            !                             ! LN(K0) OF SOLUBILITY OF CO2 (EQ. 12, WEISS, 1980) 
    170158            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    171             zcek1 = ca0 + ca1 / zt + ca2 * zlogt + ca3 * zt2 + zsal * ( ca4 + ca5 * zt + ca6 * zt2 ) 
     159            zcek1 = 9345.17/ztkel - 60.2409 + 23.3585 * LOG(zt) + zsal*(0.023517 - 0.00023656*ztkel    & 
     160            &       + 0.0047036e-4*ztkel**2) 
    172161            !                             ! SET SOLUBILITIES OF O2 AND CO2  
    173             chemc(ji,jj) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
     162            chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000. ! mol/(kg uatm) 
     163            chemc(ji,jj,2) = -1636.75 + 12.0408*ztkel - 0.0327957*ztkel**2 + 0.0000316528*ztkel**3 
     164            chemc(ji,jj,3) = 57.7 - 0.118*ztkel 
    174165            ! 
    175166         END DO 
     
    184175!CDIR NOVERRCHK 
    185176            DO ji = 1, jpi 
    186               ztkel = tsn(ji,jj,jk,jp_tem) + 273.15 
     177              ztkel = tempis(ji,jj,jk) + 273.15 
    187178              zsal  = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 
    188179              zsal2 = zsal * zsal 
    189               ztgg  = LOG( ( 298.15 - tsn(ji,jj,jk,jp_tem) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
     180              ztgg  = LOG( ( 298.15 - tempis(ji,jj,jk) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
    190181              ztgg2 = ztgg  * ztgg 
    191182              ztgg3 = ztgg2 * ztgg 
     
    210201            DO ji = 1, jpi 
    211202 
    212                ! SET PRESSION 
    213                zpres   = 1.025e-1 * fsdept(ji,jj,jk) 
     203               ! SET PRESSION ACCORDING TO SAUNDER (1980) 
     204               zplat   = SIN ( ABS(gphit(ji,jj)*3.141592654/180.) ) 
     205               zc1 = 5.92E-3 + zplat**2 * 5.25E-3 
     206               zpres = ((1-zc1)-SQRT(((1-zc1)**2)-(8.84E-6*fsdept(ji,jj,jk)))) / 4.42E-6 
     207               zpres = zpres / 10.0 
    214208 
    215209               ! SET ABSOLUTE TEMPERATURE 
    216                ztkel   = tsn(ji,jj,jk,jp_tem) + 273.15 
     210               ztkel   = tempis(ji,jj,jk) + 273.15 
    217211               zsal    = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 
    218212               zsqrt  = SQRT( zsal ) 
     
    223217               zis2   = zis * zis 
    224218               zisqrt = SQRT( zis ) 
    225                ztc     = tsn(ji,jj,jk,jp_tem) + ( 1.- tmask(ji,jj,jk) ) * 20. 
     219               ztc     = tempis(ji,jj,jk) + ( 1.- tmask(ji,jj,jk) ) * 20. 
    226220 
    227221               ! CHLORINITY (WOOSTER ET AL., 1969) 
     
    256250 
    257251 
    258                zck1    = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal * zsal 
    259                zck2    = c20 * ztr + c21 + c22 * zsal   + c23 * zsal**2 
     252               ! DISSOCIATION COEFFICIENT FOR CARBONATE ACCORDING TO  
     253               ! MEHRBACH (1973) REFIT BY MILLERO (1995), seawater scale 
     254               zck1    = -1.0*(3633.86*ztr - 61.2172 + 9.6777*zlogt  & 
     255                  - 0.011555*zsal + 0.0001152*zsal*zsal) 
     256               zck2    = -1.0*(471.78*ztr + 25.9290 - 3.16967*zlogt      & 
     257                  - 0.01781*zsal + 0.0001122*zsal*zsal) 
    260258 
    261259               ! PKW (H2O) (DICKSON AND RILEY, 1979) 
     
    266264               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    267265               !       (S=27-43, T=2-25 DEG C) at pres =0 (atmos. pressure) (MUCCI 1983) 
    268                zaksp0  = akcc1 + akcc2 * ztkel + akcc3 * ztr + akcc4 * LOG10( ztkel )   & 
    269                   &   + ( akcc5 + akcc6 * ztkel + akcc7 * ztr ) * zsqrt + akcc8 * zsal + akcc9 * zsal15 
     266               zaksp0  = -171.9065 -0.077993*ztkel + 2839.319*ztr + 71.595*LOG10( ztkel )   & 
     267                  &      + (-0.77712 + 0.00284263*ztkel + 178.34*ztr) * zsqrt  & 
     268                  &      - 0.07711*zsal + 0.0041249*zsal15 
    270269 
    271270               ! K1, K2 OF CARBONIC ACID, KB OF BORIC ACID, KW (H2O) (LIT.?) 
     
    337336      !!                     ***  ROUTINE p4z_che_alloc  *** 
    338337      !!---------------------------------------------------------------------- 
    339       ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj), chemo2(jpi,jpj,jpk),   & 
    340       &         STAT=p4z_che_alloc ) 
     338      ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,3), chemo2(jpi,jpj,jpk),   & 
     339      &         tempis(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
    341340      ! 
    342341      IF( p4z_che_alloc /= 0 )   CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r6427 r7487  
    8686      REAL(wp) ::   ztc, ztc2, ztc3, ztc4, zws, zkgwan 
    8787      REAL(wp) ::   zfld, zflu, zfld16, zflu16, zfact 
     88      REAL(wp) ::   zvapsw, zsal, zfco2, zxc2, xCO2approx, ztkel, zfugcoeff 
    8889      REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 
    8990      REAL(wp) ::   zyr_dec, zdco2dt 
    9091      CHARACTER (len=25) :: charout 
    91       REAL(wp), POINTER, DIMENSION(:,:) :: zkgco2, zkgo2, zh2co3, zoflx, zw2d  
     92      REAL(wp), POINTER, DIMENSION(:,:) :: zkgco2, zkgo2, zh2co3, zoflx, zw2d, zpco2atm  
    9293      !!--------------------------------------------------------------------- 
    9394      ! 
    9495      IF( nn_timing == 1 )  CALL timing_start('p4z_flx') 
    9596      ! 
    96       CALL wrk_alloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx ) 
     97      CALL wrk_alloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 
    9798      ! 
    9899 
     
    183184      DO jj = 1, jpj 
    184185         DO ji = 1, jpi 
     186            ztkel  = tsn(ji,jj,1,jp_tem) + 273.15 
     187            zsal   = tsn(ji,jj,1,jp_sal) + ( 1.- tmask(ji,jj,1) ) * 35. 
     188            zvapsw = EXP(24.4543 - 67.4509*(100.0/ztkel) - 4.8489*LOG(ztkel/100) - 0.000544*zsal) 
     189            zpco2atm(ji,jj) = satmco2(ji,jj) * ( patm(ji,jj) - zvapsw ) 
     190            zxc2 = (1.0 - zpco2atm(ji,jj) * 1E-6 )**2 
     191            zfugcoeff = EXP(patm(ji,jj) * (chemc(ji,jj,2) + 2.0 * zxc2 * chemc(ji,jj,3) )   & 
     192            &           / (82.05736 * ztkel)) 
     193            zfco2 = zpco2atm(ji,jj) * zfugcoeff 
     194 
    185195            ! Compute CO2 flux for the sea and air 
    186             zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
    187             zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
     196            zfld = zfco2 * chemc(ji,jj,1) * zkgco2(ji,jj)  ! (mol/L) * (m/s) 
     197            zflu = zh2co3(ji,jj) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
    188198            oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
    189199            ! compute the trend 
    190             tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) * rfact2 / fse3t(ji,jj,1) 
     200            tra(ji,jj,1,jpdic) = tra(ji,jj,1,jpdic) + ( zfld - zflu ) * rfact2 / fse3t(ji,jj,1) * tmask(ji,jj,1) 
    191201 
    192202            ! Compute O2 flux  
    193             zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
    194             zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
    195             zoflx(ji,jj) = zfld16 - zflu16 
     203            zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
     204            zflu16 = trb(ji,jj,1,jpoxy) * zkgo2(ji,jj) 
     205            zoflx(ji,jj) = ( zfld16 - zflu16 ) * tmask(ji,jj,1) 
    196206            tra(ji,jj,1,jpoxy) = tra(ji,jj,1,jpoxy) + zoflx(ji,jj) * rfact2 / fse3t(ji,jj,1) 
    197207         END DO 
     
    224234         ENDIF 
    225235         IF( iom_use( "Dpco2" ) ) THEN 
    226            zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1) 
     236           zw2d(:,:) = ( zpco2atm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
    227237           CALL iom_put( "Dpco2" ,  zw2d ) 
    228238         ENDIF 
     
    240250            trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)  
    241251            trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)  
    242             trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1)  
    243          ENDIF 
    244       ENDIF 
    245       ! 
    246       CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx ) 
     252            trc2d(:,:,jp_pcs0_2d + 3) = ( zpco2atm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
     253         ENDIF 
     254      ENDIF 
     255      ! 
     256      CALL wrk_dealloc( jpi, jpj, zkgco2, zkgo2, zh2co3, zoflx, zpco2atm ) 
    247257      ! 
    248258      IF( nn_timing == 1 )  CALL timing_stop('p4z_flx') 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90

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

    r6427 r7487  
    6565      REAL(wp) ::   zomegaca, zexcess, zexcess0 
    6666      CHARACTER (len=25) :: charout 
    67       REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zcaldiss    
     67      REAL(wp), POINTER, DIMENSION(:,:,:) :: zco3, zco3sat, zcaldiss    
    6868      !!--------------------------------------------------------------------- 
    6969      ! 
    7070      IF( nn_timing == 1 )  CALL timing_start('p4z_lys') 
    7171      ! 
    72       CALL wrk_alloc( jpi, jpj, jpk, zco3, zcaldiss ) 
     72      CALL wrk_alloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
    7373      ! 
    7474      zco3    (:,:,:) = 0. 
     
    120120               zcalcon  = calcon * ( tsn(ji,jj,jk,jp_sal) / 35._wp ) 
    121121               zfact    = rhop(ji,jj,jk) / 1000._wp 
    122                zomegaca = ( zcalcon * zco3(ji,jj,jk) * zfact ) / aksp(ji,jj,jk)  
     122               zomegaca = ( zcalcon * zco3(ji,jj,jk) ) / ( aksp(ji,jj,jk) * zfact + rtrn ) 
     123               zco3sat(ji,jj,jk) = aksp(ji,jj,jk) * zfact / ( zcalcon + rtrn ) 
    123124 
    124125               ! SET DEGREE OF UNDER-/SUPERSATURATION 
     
    149150      IF( lk_iomput .AND. knt == nrdttrc ) THEN 
    150151         IF( iom_use( "PH"     ) ) CALL iom_put( "PH"    , -1. * LOG10( hi(:,:,:) )          * tmask(:,:,:) ) 
    151          IF( iom_use( "CO3"    ) ) CALL iom_put( "CO3"   , zco3(:,:,:) * 1.e+3               * tmask(:,:,:) ) 
    152          IF( iom_use( "CO3sat" ) ) CALL iom_put( "CO3sat", aksp(:,:,:) * 1.e+3 / calcon      * tmask(:,:,:) ) 
    153          IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r   * tmask(:,:,:) ) 
     152         IF( iom_use( "CO3"    ) ) CALL iom_put( "CO3"   , zco3(:,:,:)    * 1.e+3            * tmask(:,:,:) ) 
     153         IF( iom_use( "CO3sat" ) ) CALL iom_put( "CO3sat", zco3sat(:,:,:) * 1.e+3            * tmask(:,:,:) ) 
     154         IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r * tmask(:,:,:) ) 
    154155      ELSE 
    155156         IF( ln_diatrc ) THEN 
    156157            trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
    157158            trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
    158             trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
     159            trc3d(:,:,:,jp_pcs0_3d + 2) = zco3sat(:,:,:)           * tmask(:,:,:) 
    159160         ENDIF 
    160161      ENDIF 
     
    166167      ENDIF 
    167168      ! 
    168       CALL wrk_dealloc( jpi, jpj, jpk, zco3, zcaldiss ) 
     169      CALL wrk_dealloc( jpi, jpj, jpk, zco3, zco3sat, zcaldiss ) 
    169170      ! 
    170171      IF( nn_timing == 1 )  CALL timing_stop('p4z_lys') 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

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

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

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

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

    r6427 r7487  
    3535   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   restotr   ! restoring coeff. on tracers (s-1) 
    3636 
    37    INTEGER, PARAMETER           ::   npncts   = 5        ! number of closed sea 
     37   INTEGER, PARAMETER           ::   npncts   = 8        ! number of closed sea 
    3838   INTEGER, DIMENSION(npncts)   ::   nctsi1, nctsj1      ! south-west closed sea limits (i,j) 
    3939   INTEGER, DIMENSION(npncts)   ::   nctsi2, nctsj2      ! north-east closed sea limits (i,j) 
     
    107107                
    108108               jl = n_trc_index(jn)  
    109                CALL trc_dta( kt, sf_trcdta(jl) )   ! read tracer data at nit000 
    110                ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 
     109               CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    111110 
    112111               SELECT CASE ( nn_zdmp_tr ) 
     
    187186      INTEGER :: ji , jj, jk, jn, jl, jc                     ! dummy loop indicesa 
    188187      INTEGER :: isrow                                      ! local index 
     188      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta       ! 3D  workspace 
    189189 
    190190      !!---------------------------------------------------------------------- 
     
    207207            ! 
    208208                                                        ! Caspian Sea 
    209             nctsi1(1)   = 332  ; nctsj1(1)   = 243 - isrow 
    210             nctsi2(1)   = 344  ; nctsj2(1)   = 275 - isrow 
     209            nctsi1(1)   = 333  ; nctsj1(1)   = 243 - isrow 
     210            nctsi2(1)   = 342  ; nctsj2(1)   = 274 - isrow 
     211            !                                           ! Lake Superior 
     212            nctsi1(2)   = 198  ; nctsj1(2)   = 258 - isrow 
     213            nctsi2(2)   = 204  ; nctsj2(2)   = 262 - isrow 
     214            !                                           ! Lake Michigan 
     215            nctsi1(3)   = 201  ; nctsj1(3)   = 250 - isrow 
     216            nctsi2(3)   = 203  ; nctsj2(3)   = 256 - isrow 
     217            !                                           ! Lake Huron 
     218            nctsi1(4)   = 204  ; nctsj1(4)   = 252 - isrow 
     219            nctsi2(4)   = 209  ; nctsj2(4)   = 256 - isrow 
     220            !                                           ! Lake Erie 
     221            nctsi1(5)   = 206  ; nctsj1(5)   = 249 - isrow 
     222            nctsi2(5)   = 209  ; nctsj2(5)   = 251 - isrow 
     223            !                                           ! Lake Ontario 
     224            nctsi1(6)   = 210  ; nctsj1(6)   = 252 - isrow 
     225            nctsi2(6)   = 212  ; nctsj2(6)   = 252 - isrow 
     226            !                                           ! Victoria Lake 
     227            nctsi1(7)   = 321  ; nctsj1(7)   = 180 - isrow 
     228            nctsi2(7)   = 322  ; nctsj2(7)   = 189 - isrow 
     229            !                                           ! Baltic Sea 
     230            nctsi1(8)   = 297  ; nctsj1(8)   = 270 - isrow 
     231            nctsi2(8)   = 308  ; nctsj2(8)   = 293 - isrow 
    211232            !                                         
    212233            !                                           ! ======================= 
     
    277298         IF(lwp)  WRITE(numout,*) 
    278299         ! 
     300         CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )   ! Memory allocation 
     301         ! 
    279302         DO jn = 1, jptra 
    280303            IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    281304                jl = n_trc_index(jn) 
    282                 CALL trc_dta( kt, sf_trcdta(jl) )   ! read tracer data at nit000 
     305                CALL trc_dta( kt, sf_trcdta(jl), rf_trfac(jl), ztrcdta )   ! read tracer data at nit000 
    283306                DO jc = 1, npncts 
    284307                   DO jk = 1, jpkm1 
    285308                      DO jj = nctsj1(jc), nctsj2(jc) 
    286309                         DO ji = nctsi1(jc), nctsi2(jc) 
    287                             trn(ji,jj,jk,jn) = sf_trcdta(jl)%fnow(ji,jj,jk) * tmask(ji,jj,jk) * rf_trfac(jl) 
     310                            trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) 
    288311                            trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    289312                         ENDDO 
     
    293316             ENDIF 
    294317          ENDDO 
    295           ! 
     318          CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
    296319      ENDIF 
    297320      ! 
     
    313336      IF( nn_timing == 1 )  CALL timing_start('trc_dmp_init') 
    314337      ! 
     338      !Allocate arrays 
     339      IF( trc_dmp_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'trc_dmp_init: unable to allocate arrays' ) 
    315340 
    316341      IF( lzoom )   nn_zdmp_tr = 0           ! restoring to climatology at closed north or south boundaries 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r6427 r7487  
    102102         IF(lwp) WRITE(numout,*) '~~~~~~~ ' 
    103103 
    104          IF( ln_rsttr .AND.    &                     ! Restart: read in restart  file 
     104         IF( ln_rsttr .AND. .NOT.ln_top_euler .AND.   &                     ! Restart: read in restart  file 
    105105            iom_varid( numrtr, 'sbc_'//TRIM(ctrcnm(1))//'_b', ldstop = .FALSE. ) > 0 ) THEN 
    106106            IF(lwp) WRITE(numout,*) '          nittrc000-nn_dttrc surface tracer content forcing fields red in the restart file' 
     
    190190      !                                           Write in the tracer restar  file 
    191191      !                                          ******************************* 
    192       IF( lrst_trc ) THEN 
     192      IF( lrst_trc .AND. .NOT.ln_top_euler ) THEN 
    193193         IF(lwp) WRITE(numout,*) 
    194194         IF(lwp) WRITE(numout,*) 'sbc : ocean surface tracer content forcing fields written in tracer restart file ',   & 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r6427 r7487  
    6868         IF( ln_trcdmp )        CALL trc_dmp( kstp )            ! internal damping trends 
    6969                                CALL trc_adv( kstp )            ! horizontal & vertical advection  
     70         IF( ln_zps ) THEN 
     71           IF( ln_isfcav ) THEN ; CALL zps_hde_isf( kstp, jptra, trb, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )  ! both top & bottom 
     72           ELSE                 ; CALL zps_hde    ( kstp, jptra, trb, gtru, gtrv )                                      !  only bottom 
     73           ENDIF 
     74         ENDIF 
    7075                                CALL trc_ldf( kstp )            ! lateral mixing 
    7176         IF( .NOT. lk_offline .AND. lk_zdfkpp )    & 
     
    7580#endif 
    7681                                CALL trc_zdf( kstp )            ! vertical mixing and after tracer fields 
     82         ! 
    7783                                CALL trc_nxt( kstp )            ! tracer fields at next time step      
    7884         IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
     
    8389#endif 
    8490 
    85          IF( ln_zps  .AND. .NOT. ln_isfcav)        & 
    86             &            CALL zps_hde    ( kstp, jptra, trn, gtru, gtrv )   ! Partial steps: now horizontal gradient of passive 
    87          IF( ln_zps .AND.        ln_isfcav)        & 
    88             &            CALL zps_hde_isf( kstp, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )  ! Partial steps: now horizontal gradient of passive 
    89                                                                 ! tracers at the bottom ocean level 
    90          ! 
    9191      ELSE                                               ! 1D vertical configuration 
    9292                                CALL trc_sbc( kstp )            ! surface boundary condition 
     
    100100      ! 
    101101      IF( nn_timing == 1 )   CALL timing_stop('trc_trp') 
     102      ! 
     1039400  FORMAT(a25,i4,D23.16) 
    102104      ! 
    103105   END SUBROUTINE trc_trp 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

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

    r6550 r7487  
    2727   USE trcdta          ! initialisation from files 
    2828   USE daymod          ! calendar manager 
    29    USE zpshde          ! partial step: hor. derivative   (zps_hde routine) 
    3029   USE prtctl_trc      ! Print control passive tracers (prt_ctl_trc_init routine) 
    3130   USE trcsub          ! variables to substep passive tracers 
     
    125124               IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    126125                  jl = n_trc_index(jn)  
    127                   CALL trc_dta( nit000, sf_trcdta(jl) )   ! read tracer data at nit000 
    128                   trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 
    129                   ! 
     126                  CALL trc_dta( nit000, sf_trcdta(jl), rf_trfac(jl) )   ! read tracer data at nit000 
     127                  trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:)  
    130128                  IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN      !== deallocate data structure   ==! 
    131129                     !                                                    (data used only for initialisation) 
     
    145143  
    146144      tra(:,:,:,:) = 0._wp 
    147       IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav )   &              ! Partial steps: before horizontal gradient of passive 
    148         &    CALL zps_hde    ( nit000, jptra, trn, gtru, gtrv  )  ! Partial steps: before horizontal gradient 
    149       IF( ln_zps .AND. .NOT. lk_c1d .AND.       ln_isfcav )   & 
    150         &    CALL zps_hde_isf( nit000, jptra, trn, pgtu=gtru, pgtv=gtrv, pgtui=gtrui, pgtvi=gtrvi )       ! tracers at the bottom ocean level 
    151  
    152  
    153145      ! 
    154146      IF( nn_dttrc /= 1 )        CALL trc_sub_ini      ! Initialize variables for substepping passive tracers 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/trcrst.F90

    r6427 r7487  
    304304         IF(lwp) WRITE(numout,9000) jn, TRIM( ctrcnm(jn) ), zmean, zmin, zmax, zdrift 
    305305      END DO 
    306       WRITE(numout,*)  
     306      IF(lwp) WRITE(numout,*)  
    3073079000  FORMAT(' tracer nb :',i2,'    name :',a10,'    mean :',e18.10,'    min :',e18.10, & 
    308308      &      '    max :',e18.10,'    drift :',e18.10, ' %') 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r6427 r7487  
    3333   REAL(wp) :: rdt_sampl 
    3434   INTEGER  :: nb_rec_per_day 
    35    INTEGER  :: isecfst, iseclast 
     35   REAL(wp) :: rsecfst, rseclast 
    3636   LOGICAL  :: llnew 
    3737 
     
    5959      REAL(wp)              ::  ztrai 
    6060      CHARACTER (len=25)    ::  charout  
    61  
    6261      !!------------------------------------------------------------------- 
    6362      ! 
     
    9493                                   CALL trc_sms      ( kt )       ! tracers: sinks and sources 
    9594                                   CALL trc_trp      ( kt )       ! transport of passive tracers 
     95 
    9696         IF( kt == nittrc000 ) THEN 
    9797            CALL iom_close( numrtr )       ! close input tracer restart file 
     
    105105      ENDIF 
    106106      ! 
     107 
    107108      ztrai = 0._wp                                                   !  content of all tracers 
    108109      DO jn = 1, jptra 
     
    110111      END DO 
    111112      IF( lwp ) WRITE(numstr,9300) kt,  ztrai / areatot 
    112 9300  FORMAT(i10,e18.10) 
     1139300  FORMAT(i10,D23.16) 
    113114      ! 
    114115      IF( nn_timing == 1 )   CALL timing_stop('trc_stp') 
     
    130131      INTEGER, INTENT(in) ::   kt 
    131132      INTEGER  :: jn 
     133      REAL(wp) :: zkt 
     134      CHARACTER(len=1)               ::   cl1                      ! 1 character 
     135      CHARACTER(len=2)               ::   cl2                      ! 2 characters 
    132136 
    133137      IF( kt == nittrc000 ) THEN 
    134138         IF( ln_cpl )  THEN   
    135             rdt_sampl = 86400. / ncpl_qsr_freq 
     139            rdt_sampl = rday / ncpl_qsr_freq 
    136140            nb_rec_per_day = ncpl_qsr_freq 
    137141         ELSE   
    138             rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 
    139             nb_rec_per_day = INT( 86400 / rdt_sampl ) 
     142            rdt_sampl = MAX( 3600., rdttrc(1) ) 
     143            nb_rec_per_day = INT( rday / rdt_sampl ) 
    140144         ENDIF 
    141145         ! 
     
    146150         ENDIF 
    147151         ! 
     152         ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) 
     153         ! 
    148154         !                                            !* Restart: read in restart file 
    149          IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean', ldstop = .FALSE. ) > 0 ) THEN  
    150             IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean read in the restart file' 
     155         IF( ln_rsttr .AND. iom_varid( numrtr, 'qsr_mean' , ldstop = .FALSE. ) > 0 .AND. & 
     156                            iom_varid( numrtr, 'qsr_arr_1', ldstop = .FALSE. ) > 0 .AND. & 
     157                            iom_varid( numrtr, 'ktdcy'    , ldstop = .FALSE. ) > 0 ) THEN  
     158            CALL iom_get( numrtr, 'ktdcy', zkt )   !  A mean of qsr 
     159            rsecfst = INT( zkt ) * rdttrc(1) 
     160            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean read in the restart file at time-step rsecfst =', rsecfst, ' s ' 
    151161            CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean )   !  A mean of qsr 
     162            DO jn = 1, nb_rec_per_day  
     163             IF( jn <= 9 )  THEN 
     164               WRITE(cl1,'(i1)') jn 
     165               CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) )   !  A mean of qsr 
     166             ELSE 
     167               WRITE(cl2,'(i2.2)') jn 
     168               CALL iom_get( numrtr, jpdom_autoglo, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) )   !  A mean of qsr 
     169             ENDIF 
     170           ENDDO 
    152171         ELSE                                         !* no restart: set from nit000 values 
    153172            IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean set to nit000 values' 
     173            rsecfst  = kt * rdttrc(1) 
     174            ! 
    154175            qsr_mean(:,:) = qsr(:,:) 
    155          ENDIF 
    156          ! 
    157          ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_day ) ) 
    158          DO jn = 1, nb_rec_per_day 
    159              qsr_arr(:,:,jn) = qsr_mean(:,:) 
    160          ENDDO 
    161          ! 
    162          isecfst  = nsec_year + nsec1jan000   !   number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
    163          iseclast = isecfst 
    164          ! 
    165       ENDIF 
    166       ! 
    167       iseclast = nsec_year + nsec1jan000 
    168       llnew   = ( iseclast - isecfst )  > INT( rdt_sampl )   !   new shortwave to store 
    169       IF( kt /= nittrc000 .AND. llnew ) THEN 
     176            DO jn = 1, nb_rec_per_day 
     177               qsr_arr(:,:,jn) = qsr_mean(:,:) 
     178            ENDDO 
     179         ENDIF 
     180         ! 
     181      ENDIF 
     182      ! 
     183      rseclast = kt * rdttrc(1) 
     184      ! 
     185      llnew   = ( rseclast - rsecfst ) .ge.  rdt_sampl    !   new shortwave to store 
     186      IF( llnew ) THEN 
    170187          IF( lwp ) WRITE(numout,*) ' New shortwave to sample for TOP at time kt = ', kt, & 
    171              &                      ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 
    172           isecfst = iseclast 
     188             &                      ' time = ', rseclast/3600.,'hours ' 
     189          rsecfst = rseclast 
    173190          DO jn = 1, nb_rec_per_day - 1 
    174191             qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 
     
    182199         IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file  kt =', kt 
    183200         IF(lwp) WRITE(numout,*) '~~~~~~~' 
     201         zkt = REAL( kt, wp ) 
     202         CALL iom_rstput( kt, nitrst, numrtw, 'ktdcy', zkt ) 
     203          DO jn = 1, nb_rec_per_day  
     204             IF( jn <= 9 )  THEN 
     205               WRITE(cl1,'(i1)') jn 
     206               CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl1, qsr_arr(:,:,jn) ) 
     207             ELSE 
     208               WRITE(cl2,'(i2.2)') jn 
     209               CALL iom_rstput( kt, nitrst, numrtw, 'qsr_arr_'//cl2, qsr_arr(:,:,jn) ) 
     210             ENDIF 
     211         ENDDO 
    184212         CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) 
    185213      ENDIF 
    186      ! 
     214      ! 
    187215   END SUBROUTINE trc_mean_qsr 
    188216 
  • branches/UKMO/v3_6_extra_CMIP6_diagnostics/NEMOGCM/NEMO/TOP_SRC/trcsub.F90

    r6427 r7487  
    1616   USE in_out_manager 
    1717   USE lbclnk 
    18 #if defined key_zdftke 
    19    USE zdftke          ! twice TKE (en) 
    20 #endif 
    21 #if defined key_zdfgls 
    22    USE zdfgls, ONLY: en 
    23 #endif 
    2418   USE trabbl 
    2519   USE zdf_oce 
Note: See TracChangeset for help on using the changeset viewer.