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 6625 for branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO – NEMO

Ignore:
Timestamp:
2016-05-26T11:08:07+02:00 (8 years ago)
Author:
kingr
Message:

Rolled back to r6613

Location:
branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO
Files:
128 edited

Legend:

Unmodified
Added
Removed

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_2/limistate_2.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r6617 r6625  
    253253   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fhld        !: heat flux from the lead used for bottom melting 
    254254 
    255    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange   [kg.m-2.s-1] 
    256    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice  [kg.m-2.s-1] 
    257    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow/ice sublimation       [kg.m-2.s-1] 
    258  
    259    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange                   [kg.m-2.s-1] 
    260    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice      [kg.m-2.s-1] 
    261    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice   [kg.m-2.s-1] 
    262    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice    [kg.m-2.s-1] 
    263    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg.m-2.s-1] 
    264    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice          [kg.m-2.s-1] 
    265    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice         [kg.m-2.s-1] 
    266    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice             [kg.m-2.s-1] 
    267  
    268    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total)          [s-1] 
     255   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_snw    !: snow-ocean mass exchange over 1 time step [kg/m2] 
     256   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_spr    !: snow precipitation on ice over 1 time step [kg/m2] 
     257   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sub    !: snow sublimation over 1 time step [kg/m2] 
     258 
     259   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_ice    !: ice-ocean mass exchange over 1 time step [kg/m2] 
     260   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sni    !: snow ice growth component of wfx_ice [kg/m2] 
     261   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_opw    !: lateral ice growth component of wfx_ice [kg/m2] 
     262   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bog    !: bottom ice growth component of wfx_ice [kg/m2] 
     263   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_dyn    !: dynamical ice growth component of wfx_ice [kg/m2] 
     264   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_bom    !: bottom melt component of wfx_ice [kg/m2] 
     265   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_sum    !: surface melt component of wfx_ice [kg/m2] 
     266   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_res    !: residual component of wfx_ice [kg/m2] 
     267 
     268   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_tot     !: ice concentration tendency (total) [s-1] 
    269269   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_thd     !: ice concentration tendency (thermodynamics) [s-1] 
    270    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics)       [s-1] 
     270   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   afx_dyn     !: ice concentration tendency (dynamics) [s-1] 
    271271 
    272272   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_bog     !: salt flux due to ice growth/melt                      [PSU/m2/s] 
    … …  
    279279   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_res     !: residual salt flux due to correction of ice thickness [PSU/m2/s] 
    280280 
    281    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   sfx_sub     !: salt flux due to ice sublimation 
    282  
    283    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth        [W.m-2] 
    284    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt          [W.m-2] 
    285    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt         [W.m-2] 
    286    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation [W.m-2] 
    287    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice   [W.m-2] 
    288    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt                          [W.m-2] 
    289    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion             [W.m-2] 
    290    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux [W.m-2] 
    291    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping             [W.m-2] 
    292    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations   [W.m-2] 
    293    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  [W.m-2] 
    294    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   wfx_err_sub !: mass flux error after sublimation [kg.m-2.s-1] 
    295     
     281   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bog     !: total heat flux causing bottom ice growth  
     282   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_bom     !: total heat flux causing bottom ice melt  
     283   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sum     !: total heat flux causing surface ice melt  
     284   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_opw     !: total heat flux causing open water ice formation 
     285   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dif     !: total heat flux causing Temp change in the ice  
     286   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_snw     !: heat flux for snow melt  
     287   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err     !: heat flux error after heat diffusion  
     288   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_dif !: heat flux remaining due to change in non-solar flux 
     289   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_err_rem !: heat flux error after heat remapping  
     290   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_in      !: heat flux available for thermo transformations  
     291   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_out     !: heat flux remaining at the end of thermo transformations  
     292 
    296293   ! heat flux associated with ice-atmosphere mass exchange 
    297    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  [W.m-2] 
    298    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  [W.m-2] 
     294   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_sub     !: heat flux for sublimation  
     295   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_spr     !: heat flux of the snow precipitation  
    299296 
    300297   ! heat flux associated with ice-ocean mass exchange 
    301    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  [W.m-2] 
    302    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  [W.m-2] 
    303    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness [W.m-2] 
     298   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_thd     !: ice-ocean heat flux from thermo processes (limthd_dh)  
     299   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_dyn     !: ice-ocean heat flux from mecanical processes (limitd_me)  
     300   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hfx_res     !: residual heat flux due to correction of ice thickness 
    304301 
    305302   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   ftr_ice   !: transmitted solar radiation under ice 
    306    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   rn_amax_2d  !: maximum ice concentration 2d array 
    307303 
    308304   !!-------------------------------------------------------------------------- 
    … …  
    376372   INTEGER          , PUBLIC ::   nlay_i          !: number of ice  layers  
    377373   INTEGER          , PUBLIC ::   nlay_s          !: number of snow layers  
    378    CHARACTER(len=80), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
     374   CHARACTER(len=32), PUBLIC ::   cn_icerst_in    !: suffix of ice restart name (input) 
    379375   CHARACTER(len=256), PUBLIC ::   cn_icerst_indir !: ice restart input directory 
    380    CHARACTER(len=80), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
     376   CHARACTER(len=32), PUBLIC ::   cn_icerst_out   !: suffix of ice restart name (output) 
    381377   CHARACTER(len=256), PUBLIC ::   cn_icerst_outdir!: ice restart output directory 
    382378   LOGICAL          , PUBLIC ::   ln_limdyn       !: flag for ice dynamics (T) or not (F) 
    383379   LOGICAL          , PUBLIC ::   ln_icectl       !: flag for sea-ice points output (T) or not (F) 
    384    REAL(wp)         , PUBLIC ::   rn_amax_n       !: maximum ice concentration Northern hemisphere 
    385    REAL(wp)         , PUBLIC ::   rn_amax_s       !: maximum ice concentration Southern hemisphere 
     380   REAL(wp)         , PUBLIC ::   rn_amax         !: maximum ice concentration 
    386381   INTEGER          , PUBLIC ::   iiceprt         !: debug i-point 
    387382   INTEGER          , PUBLIC ::   jiceprt         !: debug j-point 
    … …  
    443438         &      afx_tot(jpi,jpj) , afx_thd(jpi,jpj),  afx_dyn(jpi,jpj) ,                        & 
    444439         &      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) ,                       & 
     440         &      sfx_res(jpi,jpj) , sfx_bri(jpi,jpj) , sfx_dyn(jpi,jpj) ,                        & 
    447441         &      sfx_bog(jpi,jpj) , sfx_bom(jpi,jpj) , sfx_sum(jpi,jpj) , sfx_sni(jpi,jpj) , sfx_opw(jpi,jpj) ,    & 
    448442         &      hfx_res(jpi,jpj) , hfx_snw(jpi,jpj) , hfx_sub(jpi,jpj) , hfx_err(jpi,jpj) ,     &  
    449          &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) , wfx_err_sub(jpi,jpj) ,       & 
     443         &      hfx_err_dif(jpi,jpj) , hfx_err_rem(jpi,jpj) ,                                   & 
    450444         &      hfx_in (jpi,jpj) , hfx_out(jpi,jpj) , fhld(jpi,jpj) ,                           & 
    451445         &      hfx_sum(jpi,jpj) , hfx_bom(jpi,jpj) , hfx_bog(jpi,jpj) , hfx_dif(jpi,jpj) , hfx_opw(jpi,jpj) ,    & 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r6617 r6625  
    2424   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    2525   USE sbc_oce , ONLY : sfx  ! Surface boundary condition: ocean fields 
    26    USE sbc_ice , ONLY : qevap_ice 
    27     
     26 
    2827   IMPLICIT NONE 
    2928   PRIVATE 
    … …  
    185184         ! salt flux 
    186185         zfs_b  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    187             &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   & 
     186            &                  sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  & 
    188187            &                ) *  e12t(:,:) * tmask(:,:,1) * zconv ) 
    189188 
    … …  
    210209         ! salt flux 
    211210         zfs  = glob_sum(  ( sfx_bri(:,:) + sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) +  & 
    212             &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:) + sfx_sub(:,:)                   &  
     211            &                sfx_opw(:,:) + sfx_res(:,:) + sfx_dyn(:,:)                                  &  
    213212            &              ) * e12t(:,:) * tmask(:,:,1) * zconv ) - zfs_b 
    214213 
    … …  
    257256            ENDIF 
    258257            IF (     zvmin   < -epsi10 ) WRITE(numout,*) 'violation v_i<0  [m]          (',cd_routine,') = ',zvmin 
    259             IF (     zamax   > MAX( rn_amax_n, rn_amax_s ) + epsi10 .AND. & 
    260                &                         cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
     258            IF (     zamax   > rn_amax+epsi10 .AND. cd_routine /= 'limtrp' .AND. cd_routine /= 'limitd_me' ) THEN 
    261259                                         WRITE(numout,*) 'violation a_i>amax            (',cd_routine,') = ',zamax 
    262260            ENDIF 
    … …  
    288286#if ! defined key_bdy 
    289287      ! 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 )  
     288      zhfx  = glob_sum( ( hfx_in - hfx_out - diag_heat - diag_trp_ei - diag_trp_es - hfx_sub ) * e12t * tmask(:,:,1) * zconv )  
    292289      ! salt flux 
    293290      zsfx  = glob_sum( ( sfx + diag_smvi ) * e12t * tmask(:,:,1) * zconv ) * rday 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limdiahsb.F90

    r6617 r6625  
    5656      real(wp)   ::   zbg_ivo, zbg_svo, zbg_are, zbg_sal ,zbg_tem ,zbg_ihc ,zbg_shc 
    5757      real(wp)   ::   zbg_sfx, zbg_sfx_bri, zbg_sfx_bog, zbg_sfx_bom, zbg_sfx_sum, zbg_sfx_sni,   & 
    58       &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn, zbg_sfx_sub  
     58      &               zbg_sfx_opw, zbg_sfx_res, zbg_sfx_dyn  
    5959      real(wp)   ::   zbg_vfx, zbg_vfx_bog, zbg_vfx_opw, zbg_vfx_sni, zbg_vfx_dyn 
    6060      real(wp)   ::   zbg_vfx_bom, zbg_vfx_sum, zbg_vfx_res, zbg_vfx_spr, zbg_vfx_snw, zbg_vfx_sub   
    … …  
    111111      zbg_sfx_bom = ztmp * glob_sum( sfx_bom(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    112112      zbg_sfx_sum = ztmp * glob_sum( sfx_sum(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    113       zbg_sfx_sub = ztmp * glob_sum( sfx_sub(:,:) * e12t(:,:) * tmask(:,:,1) ) 
    114113 
    115114      ! Heat budget 
    … …  
    190189      CALL iom_put( 'ibgsfxbom' , zbg_sfx_bom                              )   ! salt flux bottom melt       - 
    191190      CALL iom_put( 'ibgsfxsum' , zbg_sfx_sum                              )   ! salt flux surface melt      - 
    192       CALL iom_put( 'ibgsfxsub' , zbg_sfx_sub                              )   ! salt flux sublimation      - 
    193191 
    194192      CALL iom_put( 'ibghfxdhc' , zbg_hfx_dhc                              )   ! Heat content variation in snow and ice [W] 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r6617 r6625  
    117117 
    118118      ! basal temperature (considered at freezing point) 
    119       CALL eos_fzp( sss_m(:,:), t_bo(:,:) ) 
    120       t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1)  
     119      t_bo(:,:) = ( eos_fzp( sss_m(:,:) ) + rt0 ) * tmask(:,:,1)  
    121120 
    122121      IF( ln_iceini ) THEN 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r6617 r6625  
    159159      CALL wrk_alloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    160160      CALL wrk_alloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    161       CALL wrk_alloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
     161      CALL wrk_alloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
    162162 
    163163#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    690690      CALL wrk_dealloc( jpi,jpj, u_oce2, u_ice2, v_oce1 , v_ice1 , zmask               ) 
    691691      CALL wrk_dealloc( jpi,jpj, zf1   , zu_ice, zf2   , zv_ice , zdt    , zds  ) 
    692       CALL wrk_dealloc( jpi,jpj, zs1   , zs2   , zs12   , zresr , zpice                 ) 
     692      CALL wrk_dealloc( jpi,jpj, zdt   , zds   , zs1   , zs2   , zs12   , zresr , zpice                 ) 
    693693 
    694694   END SUBROUTINE lim_rhg 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r6617 r6625  
    9494      !!              - fr_i    : ice fraction 
    9595      !!              - tn_ice  : sea-ice surface temperature 
    96       !!              - alb_ice : sea-ice albedo (recomputed only for coupled mode) 
     96      !!              - alb_ice : sea-ice albedo (only useful in coupled mode) 
    9797      !! 
    9898      !! References : Goosse, H. et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90. 
    … …  
    106106      REAL(wp) ::   zqsr                                           ! New solar flux received by the ocean 
    107107      ! 
    108       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 3D workspace 
    109       REAL(wp), POINTER, DIMENSION(:,:)   ::   zalb                 ! 2D workspace 
     108      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zalb_cs, zalb_os     ! 2D/3D workspace 
    110109      !!--------------------------------------------------------------------- 
    111110 
    112111      ! 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) 
    114112      IF( iom_use('qsr_oce') )   CALL iom_put( "qsr_oce" , qsr_oce(:,:) * pfrld(:,:) )                                   !     solar flux at ocean surface 
    115113      IF( iom_use('qns_oce') )   CALL iom_put( "qns_oce" , qns_oce(:,:) * pfrld(:,:) + qemp_oce(:,:) )                   ! non-solar flux at ocean surface 
    … …  
    120118      IF( iom_use('qt_ice' ) )   CALL iom_put( "qt_ice"  , SUM( ( qns_ice(:,:,:) + qsr_ice(:,:,:) )   & 
    121119         &                                                      * 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 
    128       CALL wrk_alloc( jpi,jpj, zalb )     
    129  
    130       zalb(:,:) = 0._wp 
    131       WHERE     ( SUM( a_i_b, dim=3 ) <= epsi06 )  ;  zalb(:,:) = 0.066_wp 
    132       ELSEWHERE                                    ;  zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) 
    133       END WHERE 
    134       IF( iom_use('alb_ice' ) )  CALL iom_put( "alb_ice"  , zalb(:,:) )           ! ice albedo output 
    135  
    136       zalb(:,:) = SUM( alb_ice * a_i_b, dim=3 ) + 0.066_wp * ( 1._wp - SUM( a_i_b, dim=3 ) )       
    137       IF( iom_use('albedo'  ) )  CALL iom_put( "albedo"  , zalb(:,:) )           ! ice albedo output 
    138  
    139       CALL wrk_dealloc( jpi,jpj, zalb )     
    140       ! 
    141        
     120      IF( iom_use('qemp_oce' ) )   CALL iom_put( "qemp_oce"  , qemp_oce(:,:) )   
     121      IF( iom_use('qemp_ice' ) )   CALL iom_put( "qemp_ice"  , qemp_ice(:,:) )   
     122 
     123      ! pfrld is the lead fraction at the previous time step (actually between TRP and THD) 
    142124      DO jj = 1, jpj 
    143125         DO ji = 1, jpi 
    … …  
    158140            hfx_out(ji,jj) = hfx_out(ji,jj) + zqmass + zqsr 
    159141 
    160             ! Add the residual from heat diffusion equation and sublimation (W.m-2) 
    161             !---------------------------------------------------------------------- 
    162             hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) +   & 
    163                &           ( hfx_sub(ji,jj) - SUM( qevap_ice(ji,jj,:) * a_i_b(ji,jj,:) ) ) 
     142            ! Add the residual from heat diffusion equation (W.m-2) 
     143            !------------------------------------------------------- 
     144            hfx_out(ji,jj) = hfx_out(ji,jj) + hfx_err_dif(ji,jj) 
    164145 
    165146            ! New qsr and qns used to compute the oceanic heat flux at the next time step 
    166             !---------------------------------------------------------------------------- 
     147            !--------------------------------------------------- 
    167148            qsr(ji,jj) = zqsr                                       
    168149            qns(ji,jj) = hfx_out(ji,jj) - zqsr               
    … …  
    184165 
    185166            ! mass flux at the ocean/ice interface 
    186             fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) + wfx_err_sub(ji,jj) )              ! F/M mass flux save at least for biogeochemical model 
    187             emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj) - wfx_err_sub(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
     167            fmmflx(ji,jj) = - ( wfx_ice(ji,jj) + wfx_snw(ji,jj) ) * r1_rdtice  ! F/M mass flux save at least for biogeochemical model 
     168            emp(ji,jj)    = emp_oce(ji,jj) - wfx_ice(ji,jj) - wfx_snw(ji,jj)   ! mass flux + F/M mass flux (always ice/ocean mass exchange) 
     169             
    188170         END DO 
    189171      END DO 
    … …  
    193175      !------------------------------------------! 
    194176      sfx(:,:) = sfx_bog(:,:) + sfx_bom(:,:) + sfx_sum(:,:) + sfx_sni(:,:) + sfx_opw(:,:)   & 
    195          &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) + sfx_sub(:,:) 
     177         &     + sfx_res(:,:) + sfx_dyn(:,:) + sfx_bri(:,:) 
    196178 
    197179      !-------------------------------------------------------------! 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r6617 r6625  
    461461 
    462462      DO ji = kideb, kiut 
    463          zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) ) 
     463         zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) ) 
    464464         IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp )  THEN 
    465465            zvi          = a_i_1d(ji) * ht_i_1d(ji) 
    … …  
    470470            zda_mel     = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) ) 
    471471            a_i_1d(ji)  = MAX( epsi20, a_i_1d(ji) + zda_mel )  
    472             ! adjust thickness 
     472             ! adjust thickness 
    473473            ht_i_1d(ji) = zvi / a_i_1d(ji)             
    474474            ht_s_1d(ji) = zvs / a_i_1d(ji)             
    … …  
    514514          
    515515         CALL tab_2d_1d( nbpb, qprec_ice_1d(1:nbpb), qprec_ice(:,:) , jpi, jpj, npb(1:nbpb) ) 
    516          CALL tab_2d_1d( nbpb, qevap_ice_1d(1:nbpb), qevap_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    517516         CALL tab_2d_1d( nbpb, qsr_ice_1d (1:nbpb), qsr_ice(:,:,jl) , jpi, jpj, npb(1:nbpb) ) 
    518517         CALL tab_2d_1d( nbpb, fr1_i0_1d  (1:nbpb), fr1_i0          , jpi, jpj, npb(1:nbpb) ) 
    … …  
    544543         CALL tab_2d_1d( nbpb, sfx_bri_1d (1:nbpb), sfx_bri         , jpi, jpj, npb(1:nbpb) ) 
    545544         CALL tab_2d_1d( nbpb, sfx_res_1d (1:nbpb), sfx_res         , jpi, jpj, npb(1:nbpb) ) 
    546          CALL tab_2d_1d( nbpb, sfx_sub_1d (1:nbpb), sfx_sub         , jpi, jpj,npb(1:nbpb) ) 
    547   
     545          
    548546         CALL tab_2d_1d( nbpb, hfx_thd_1d (1:nbpb), hfx_thd         , jpi, jpj, npb(1:nbpb) ) 
    549547         CALL tab_2d_1d( nbpb, hfx_spr_1d (1:nbpb), hfx_spr         , jpi, jpj, npb(1:nbpb) ) 
    … …  
    595593         CALL tab_1d_2d( nbpb, sfx_res       , npb, sfx_res_1d(1:nbpb)   , jpi, jpj ) 
    596594         CALL tab_1d_2d( nbpb, sfx_bri       , npb, sfx_bri_1d(1:nbpb)   , jpi, jpj ) 
    597          CALL tab_1d_2d( nbpb, sfx_sub       , npb, sfx_sub_1d(1:nbpb)   , jpi, jpj )         
    598   
     595          
    599596         CALL tab_1d_2d( nbpb, hfx_thd       , npb, hfx_thd_1d(1:nbpb)   , jpi, jpj ) 
    600597         CALL tab_1d_2d( nbpb, hfx_spr       , npb, hfx_spr_1d(1:nbpb)   , jpi, jpj ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r6617 r6625  
    7474 
    7575      REAL(wp) ::   ztmelts             ! local scalar 
    76       REAL(wp) ::   zdum        
     76      REAL(wp) ::   zfdum        
    7777      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    7878      REAL(wp) ::   zs_snic      ! snow-ice salinity 
    … …  
    9595      REAL(wp), POINTER, DIMENSION(:) ::   zq_rema     ! remaining heat at the end of the routine    (J.m-2) 
    9696      REAL(wp), POINTER, DIMENSION(:) ::   zf_tt       ! Heat budget to determine melting or freezing(W.m-2) 
    97       REAL(wp), POINTER, DIMENSION(:) ::   zevap_rema  ! remaining mass flux from sublimation        (kg.m-2) 
    9897 
    9998      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel   ! snow melt  
    … …  
    106105 
    107106      REAL(wp), POINTER, DIMENSION(:) ::   zqh_i       ! total ice heat content  (J.m-2) 
     107      REAL(wp), POINTER, DIMENSION(:) ::   zqh_s       ! total snow heat content (J.m-2) 
     108      REAL(wp), POINTER, DIMENSION(:) ::   zq_s        ! total snow enthalpy     (J.m-3) 
    108109      REAL(wp), POINTER, DIMENSION(:) ::   zsnw        ! distribution of snow after wind blowing 
    109110 
    … …  
    121122      END SELECT 
    122123 
    123       CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
    124       CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
     124      CALL wrk_alloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
     125      CALL wrk_alloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    125126      CALL wrk_alloc( jpij, nlay_i, zdeltah, zh_i ) 
    126127      CALL wrk_alloc( jpij, nlay_i, icount ) 
    127128        
    128       dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp ; dh_i_sub(:) = 0._wp 
     129      dh_i_surf  (:) = 0._wp ; dh_i_bott  (:) = 0._wp ; dh_snowice(:) = 0._wp 
    129130      dsm_i_se_1d(:) = 0._wp ; dsm_i_si_1d(:) = 0._wp    
    130131 
    131132      zqprec   (:) = 0._wp ; zq_su    (:) = 0._wp ; zq_bo    (:) = 0._wp ; zf_tt(:) = 0._wp 
    132       zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp ; zevap_rema(:) = 0._wp ; 
     133      zq_rema  (:) = 0._wp ; zsnw     (:) = 0._wp 
    133134      zdh_s_mel(:) = 0._wp ; zdh_s_pre(:) = 0._wp ; zdh_s_sub(:) = 0._wp ; zqh_i(:) = 0._wp 
     135      zqh_s    (:) = 0._wp ; zq_s     (:) = 0._wp      
    134136 
    135137      zdeltah(:,:) = 0._wp ; zh_i(:,:) = 0._wp        
    … …  
    157159      ! 
    158160      DO ji = kideb, kiut 
    159          zdum       = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
     161         zfdum      = qns_ice_1d(ji) + ( 1._wp - i0(ji) ) * qsr_ice_1d(ji) - fc_su(ji)  
    160162         zf_tt(ji)  = fc_bo_i(ji) + fhtur_1d(ji) + fhld_1d(ji)  
    161163 
    162          zq_su (ji) = MAX( 0._wp, zdum      * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
     164         zq_su (ji) = MAX( 0._wp, zfdum     * rdt_ice ) * MAX( 0._wp , SIGN( 1._wp, t_su_1d(ji) - rt0 ) ) 
    163165         zq_bo (ji) = MAX( 0._wp, zf_tt(ji) * rdt_ice ) 
    164166      END DO 
    … …  
    185187      !  2) Computing layer thicknesses and enthalpies.            ! 
    186188      !------------------------------------------------------------! 
     189      ! 
     190      DO jk = 1, nlay_s 
     191         DO ji = kideb, kiut 
     192            zqh_s(ji) =  zqh_s(ji) + q_s_1d(ji,jk) * ht_s_1d(ji) * r1_nlay_s 
     193         END DO 
     194      END DO 
    187195      ! 
    188196      DO jk = 1, nlay_i 
    … …  
    267275      END DO 
    268276 
    269       !------------------------------ 
    270       ! 3.2 Sublimation (part1: snow)  
    271       !------------------------------ 
     277      !---------------------- 
     278      ! 3.2 Snow sublimation  
     279      !---------------------- 
    272280      ! qla_ice is always >=0 (upwards), heat goes to the atmosphere, therefore snow sublimates 
    273281      ! clem comment: not counted in mass/heat exchange in limsbc since this is an exchange with atm. (not ocean) 
     282      ! clem comment: ice should also sublimate 
    274283      zdeltah(:,:) = 0._wp 
    275       DO ji = kideb, kiut 
    276          zdh_s_sub(ji)  = MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
    277          ! remaining evap in kg.m-2 (used for ice melting later on) 
    278          zevap_rema(ji)  = evap_ice_1d(ji) * rdt_ice + zdh_s_sub(ji) * rhosn 
    279          ! Heat flux by sublimation [W.m-2], < 0 (sublimate first snow that had fallen, then pre-existing snow) 
     284      ! coupled mode: sublimation is set to 0 (evap_ice = 0) until further notice 
     285      ! forced  mode: snow thickness change due to sublimation 
     286      DO ji = kideb, kiut 
     287         zdh_s_sub(ji)  =  MAX( - ht_s_1d(ji) , - evap_ice_1d(ji) * r1_rhosn * rdt_ice ) 
     288         ! Heat flux by sublimation [W.m-2], < 0 
     289         !      sublimate first snow that had fallen, then pre-existing snow 
    280290         zdeltah(ji,1)  = MAX( zdh_s_sub(ji), - zdh_s_pre(ji) ) 
    281291         hfx_sub_1d(ji) = hfx_sub_1d(ji) + ( zdeltah(ji,1) * zqprec(ji) + ( zdh_s_sub(ji) - zdeltah(ji,1) ) * q_s_1d(ji,1)  & 
    … …  
    299309      !------------------------------------------- 
    300310      ! new temp and enthalpy of the snow (remaining snow precip + remaining pre-existing snow) 
     311      zq_s(:) = 0._wp  
    301312      DO jk = 1, nlay_s 
    302313         DO ji = kideb,kiut 
    303             rswitch       = MAX( 0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 ) ) 
    304             q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *           & 
    305               &            ( ( zdh_s_pre(ji)               ) * zqprec(ji) +  & 
    306               &              ( ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
     314            rswitch       = MAX(  0._wp , SIGN( 1._wp, ht_s_1d(ji) - epsi20 )  ) 
     315            q_s_1d(ji,jk) = rswitch / MAX( ht_s_1d(ji), epsi20 ) *                          & 
     316              &            ( (   zdh_s_pre(ji)             ) * zqprec(ji) +  & 
     317              &              (   ht_s_1d(ji) - zdh_s_pre(ji) ) * rhosn * ( cpic * ( rt0 - t_s_1d(ji,jk) ) + lfus ) ) 
     318            zq_s(ji)     =  zq_s(ji) + q_s_1d(ji,jk) 
    307319         END DO 
    308320      END DO 
    … …  
    358370               zQm            = zfmdt * zEw                           ! Energy of the melt water sent to the ocean [J/m2, <0] 
    359371                
    360                ! Contribution to salt flux >0 (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
     372               ! Contribution to salt flux (clem: using sm_i_1d and not s_i_1d(jk) is ok) 
    361373               sfx_sum_1d(ji) = sfx_sum_1d(ji) - rhoic * a_i_1d(ji) * zdeltah(ji,jk) * sm_i_1d(ji) * r1_rdtice 
    362374                
    … …  
    371383                
    372384            END IF 
    373             ! ---------------------- 
    374             ! Sublimation part2: ice 
    375             ! ---------------------- 
    376             zdum      = MAX( - ( zh_i(ji,jk) + zdeltah(ji,jk) ) , - zevap_rema(ji) * r1_rhoic ) 
    377             zdeltah(ji,jk) = zdeltah(ji,jk) + zdum 
    378             dh_i_sub(ji)  = dh_i_sub(ji) + zdum 
    379             ! Salt flux > 0 (clem2016: flux is sent to the ocean for simplicity but salt should remain in the ice except if all ice is melted. 
    380             !                          It must be corrected at some point) 
    381             sfx_sub_1d(ji) = sfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * sm_i_1d(ji) * r1_rdtice 
    382             ! Heat flux [W.m-2], < 0 
    383             hfx_sub_1d(ji) = hfx_sub_1d(ji) + zdum * q_i_1d(ji,jk) * a_i_1d(ji) * r1_rdtice 
    384             ! Mass flux > 0 
    385             wfx_sub_1d(ji) =  wfx_sub_1d(ji) - rhoic * a_i_1d(ji) * zdum * r1_rdtice 
    386             ! update remaining mass flux 
    387             zevap_rema(ji)  = zevap_rema(ji) + zdum * rhoic 
    388              
    389385            ! record which layers have disappeared (for bottom melting)  
    390386            !    => icount=0 : no layer has vanished 
    … …  
    393389            icount(ji,jk) = NINT( rswitch ) 
    394390            zh_i(ji,jk)   = MAX( 0._wp , zh_i(ji,jk) + zdeltah(ji,jk) ) 
    395                          
     391 
    396392            ! update heat content (J.m-2) and layer thickness 
    397393            qh_i_old(ji,jk) = qh_i_old(ji,jk) + zdeltah(ji,jk) * q_i_1d(ji,jk) 
    … …  
    401397      ! update ice thickness 
    402398      DO ji = kideb, kiut 
    403          ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) + dh_i_sub(ji) ) 
    404       END DO 
    405  
    406       ! remaining "potential" evap is sent to ocean 
    407       DO ji = kideb, kiut 
    408          ii = MOD( npb(ji) - 1, jpi ) + 1 ; ij = ( npb(ji) - 1 ) / jpi + 1 
    409          wfx_err_sub(ii,ij) = wfx_err_sub(ii,ij) - zevap_rema(ji) * a_i_1d(ji) * r1_rdtice  ! <=0 (net evap for the ocean in kg.m-2.s-1) 
     399         ht_i_1d(ji) =  MAX( 0._wp , ht_i_1d(ji) + dh_i_surf(ji) ) 
    410400      END DO 
    411401 
    … …  
    696686      WHERE( ht_i_1d == 0._wp ) a_i_1d = 0._wp 
    697687       
    698       CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw, zevap_rema ) 
    699       CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i ) 
     688      CALL wrk_dealloc( jpij, zqprec, zq_su, zq_bo, zf_tt, zq_rema, zsnw ) 
     689      CALL wrk_dealloc( jpij, zdh_s_mel, zdh_s_pre, zdh_s_sub, zqh_i, zqh_s, zq_s ) 
    700690      CALL wrk_dealloc( jpij, nlay_i, zdeltah, zh_i ) 
    701691      CALL wrk_dealloc( jpij, nlay_i, icount ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r6617 r6625  
    7575      INTEGER ::   ii, ij, iter     !   -       - 
    7676      REAL(wp)  ::   ztmelts, zdv, zfrazb, zweight, zde                         ! local scalars 
    77       REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf                     !   -      - 
     77      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      - 
    7878      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
     79      LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness 
    7980      CHARACTER (len = 15) :: fieldid 
    8081 
    … …  
    107108      REAL(wp), POINTER, DIMENSION(:,:) ::   zsmv_i_1d ! 1-D version of smv_i 
    108109 
    109       REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d !: 1-D version of e_i 
    110  
    111       REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel     ! relative ice / frazil velocity 
    112  
    113       REAL(wp) :: zcai = 1.4e-3_wp                     ! ice-air drag (clem: should be dependent on coupling/forcing used) 
     110      REAL(wp), POINTER, DIMENSION(:,:,:) ::   ze_i_1d   !: 1-D version of e_i 
     111 
     112      REAL(wp), POINTER, DIMENSION(:,:) ::   zvrel                   ! relative ice / frazil velocity 
     113 
     114      REAL(wp) :: zcai = 1.4e-3_wp 
    114115      !!-----------------------------------------------------------------------! 
    115116 
    … …  
    142143      !------------------------------------------------------------------------------!     
    143144      ! hicol is the thickness of new ice formed in open water 
    144       ! hicol can be either prescribed (frazswi = 0) or computed (frazswi = 1) 
     145      ! hicol can be either prescribed (frazswi = 0) 
     146      ! or computed (frazswi = 1) 
    145147      ! Frazil ice forms in open water, is transported by wind 
    146148      ! accumulates at the edge of the consolidated ice edge 
    … …  
    153155      zvrel(:,:) = 0._wp 
    154156 
    155       ! Default new ice thickness 
    156       WHERE( qlead(:,:) < 0._wp ) ; hicol = rn_hnewice 
    157       ELSEWHERE                   ; hicol = 0._wp 
    158       END WHERE 
     157      ! Default new ice thickness  
     158      hicol(:,:) = rn_hnewice 
    159159 
    160160      IF( ln_frazil ) THEN 
    … …  
    182182                     &          +   vtau_ice(ji  ,jj  ) * vmask(ji  ,jj  ,1) ) * 0.5_wp 
    183183                  ! Square root of wind stress 
    184                   ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) ) 
     184                  ztenagm       =  SQRT( SQRT( ztaux**2 + ztauy**2 ) ) 
    185185 
    186186                  !--------------------- 
    … …  
    205205                  zvrel2 = MAX(  ( zvfrx - zvgx ) * ( zvfrx - zvgx )   & 
    206206                     &         + ( zvfry - zvgy ) * ( zvfry - zvgy ) , 0.15 * 0.15 ) 
    207                   zvrel(ji,jj) = SQRT( zvrel2 ) 
     207                  zvrel(ji,jj)  = SQRT( zvrel2 ) 
    208208 
    209209                  !--------------------- 
    210210                  ! Iterative procedure 
    211211                  !--------------------- 
    212                   hicol(ji,jj) = zhicrit +   ( zhicrit + 0.1 )    & 
    213                      &                   / ( ( zhicrit + 0.1 ) * ( zhicrit + 0.1 ) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
     212                  hicol(ji,jj) = zhicrit + 0.1  
     213                  hicol(ji,jj) = zhicrit +   hicol(ji,jj)    & 
     214                     &                   / ( hicol(ji,jj) * hicol(ji,jj) -  zhicrit * zhicrit ) * ztwogp * zvrel2 
     215 
     216!!gm better coding: above: hicol(ji,jj) * hicol(ji,jj) = (zhicrit + 0.1)*(zhicrit + 0.1) 
     217!!gm                                                   = zhicrit**2 + 0.2*zhicrit +0.01 
     218!!gm                therefore the 2 lines with hicol can be replaced by 1 line: 
     219!!gm              hicol(ji,jj) = zhicrit + (zhicrit + 0.1) / ( 0.2 * zhicrit + 0.01 ) * ztwogp * zvrel2 
     220!!gm further more (zhicrit + 0.1)/(0.2 * zhicrit + 0.01 )*ztwogp can be computed one for all outside the DO loop 
    214221 
    215222                  iter = 1 
    216                   DO WHILE ( iter < 20 )  
    217                      zf  = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj) * hicol(ji,jj) - zhicrit * zhicrit ) -   & 
    218                         &    hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
    219                      zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0 * hicol(ji,jj) + zhicrit ) - zhicrit * ztwogp * zvrel2 
    220  
    221                      hicol(ji,jj) = hicol(ji,jj) - zf/zfp 
     223                  iterate_frazil = .true. 
     224 
     225                  DO WHILE ( iter < 100 .AND. iterate_frazil )  
     226                     zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) & 
     227                        - hicol(ji,jj) * zhicrit * ztwogp * zvrel2 
     228                     zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) & 
     229                        - zhicrit * ztwogp * zvrel2 
     230                     zhicol_new = hicol(ji,jj) - zf/zfp 
     231                     hicol(ji,jj)   = zhicol_new 
     232 
    222233                     iter = iter + 1 
    223                   END DO 
     234 
     235                  END DO ! do while 
    224236 
    225237               ENDIF ! end of selection of pixels where ice forms 
    226238 
    227             END DO  
    228          END DO  
    229          !  
    230          CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
    231          CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
     239            END DO ! loop on ji ends 
     240         END DO ! loop on jj ends 
     241      !  
     242      CALL lbc_lnk( zvrel(:,:), 'T', 1. ) 
     243      CALL lbc_lnk( hicol(:,:), 'T', 1. ) 
    232244 
    233245      ENDIF ! End of computation of frazil ice collection thickness 
    … …  
    270282      ! Move from 2-D to 1-D vectors 
    271283      !------------------------------ 
    272       ! If ocean gains heat do nothing. Otherwise compute new ice formation 
     284      ! If ocean gains heat do nothing  
     285      ! 0therwise compute new ice formation 
    273286 
    274287      IF ( nbpac > 0 ) THEN 
    … …  
    284297         END DO 
    285298 
    286          CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead     , jpi, jpj, npac(1:nbpac) ) 
    287          CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo      , jpi, jpj, npac(1:nbpac) ) 
    288          CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw   , jpi, jpj, npac(1:nbpac) ) 
    289          CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw   , jpi, jpj, npac(1:nbpac) ) 
    290          CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol     , jpi, jpj, npac(1:nbpac) ) 
    291          CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel     , jpi, jpj, npac(1:nbpac) ) 
    292  
    293          CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd   , jpi, jpj, npac(1:nbpac) ) 
    294          CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw   , jpi, jpj, npac(1:nbpac) ) 
    295          CALL tab_2d_1d( nbpac, rn_amax_1d(1:nbpac)     , rn_amax_2d, jpi, jpj, npac(1:nbpac) ) 
     299         CALL tab_2d_1d( nbpac, qlead_1d  (1:nbpac)     , qlead  , jpi, jpj, npac(1:nbpac) ) 
     300         CALL tab_2d_1d( nbpac, t_bo_1d   (1:nbpac)     , t_bo   , jpi, jpj, npac(1:nbpac) ) 
     301         CALL tab_2d_1d( nbpac, sfx_opw_1d(1:nbpac)     , sfx_opw, jpi, jpj, npac(1:nbpac) ) 
     302         CALL tab_2d_1d( nbpac, wfx_opw_1d(1:nbpac)     , wfx_opw, jpi, jpj, npac(1:nbpac) ) 
     303         CALL tab_2d_1d( nbpac, hicol_1d  (1:nbpac)     , hicol  , jpi, jpj, npac(1:nbpac) ) 
     304         CALL tab_2d_1d( nbpac, zvrel_1d  (1:nbpac)     , zvrel  , jpi, jpj, npac(1:nbpac) ) 
     305 
     306         CALL tab_2d_1d( nbpac, hfx_thd_1d(1:nbpac)     , hfx_thd, jpi, jpj, npac(1:nbpac) ) 
     307         CALL tab_2d_1d( nbpac, hfx_opw_1d(1:nbpac)     , hfx_opw, jpi, jpj, npac(1:nbpac) ) 
    296308 
    297309         !------------------------------------------------------------------------------! 
    … …  
    304316         zv_b(1:nbpac,:) = zv_i_1d(1:nbpac,:)  
    305317         za_b(1:nbpac,:) = za_i_1d(1:nbpac,:) 
    306  
    307318         !---------------------- 
    308319         ! Thickness of new ice 
    309320         !---------------------- 
    310          zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
     321         DO ji = 1, nbpac 
     322            zh_newice(ji) = rn_hnewice 
     323         END DO 
     324         IF( ln_frazil ) zh_newice(1:nbpac) = hicol_1d(1:nbpac) 
    311325 
    312326         !---------------------- 
    … …  
    370384            ! salt flux 
    371385            sfx_opw_1d(ji) = sfx_opw_1d(ji) - zv_newice(ji) * rhoic * zs_newice(ji) * r1_rdtice 
    372          END DO 
    373           
    374          zv_frazb(:) = 0._wp 
    375          IF( ln_frazil ) THEN 
     386 
    376387            ! A fraction zfrazb of frazil ice is accreted at the ice bottom 
    377             DO ji = 1, nbpac 
    378                rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
    379                zfrazb        = rswitch * ( TANH( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
    380                zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
    381                zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
    382             END DO 
    383          END IF 
    384           
     388            rswitch       = 1._wp - MAX( 0._wp, SIGN( 1._wp , - zat_i_1d(ji) ) ) 
     389            zfrazb        = rswitch * ( TANH ( rn_Cfrazb * ( zvrel_1d(ji) - rn_vfrazb ) ) + 1.0 ) * 0.5 * rn_maxfrazb 
     390            zv_frazb(ji)  =         zfrazb   * zv_newice(ji) 
     391            zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji) 
     392         END DO 
     393 
    385394         !----------------- 
    386395         ! Area of new ice 
    … …  
    400409         ! we keep the excessive volume in memory and attribute it later to bottom accretion 
    401410         DO ji = 1, nbpac 
    402             IF ( za_newice(ji) >  ( rn_amax_1d(ji) - zat_i_1d(ji) ) ) THEN 
    403                zda_res(ji)   = za_newice(ji) - ( rn_amax_1d(ji) - zat_i_1d(ji) ) 
     411            IF ( za_newice(ji) >  ( rn_amax - zat_i_1d(ji) ) ) THEN 
     412               zda_res(ji)   = za_newice(ji) - ( rn_amax - zat_i_1d(ji) ) 
    404413               zdv_res(ji)   = zda_res  (ji) * zh_newice(ji)  
    405414               za_newice(ji) = za_newice(ji) - zda_res  (ji) 
    … …  
    434443               jl = jcat(ji) 
    435444               rswitch = MAX( 0._wp, SIGN( 1._wp , zv_i_1d(ji,jl) - epsi20 ) ) 
    436                ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                    & 
     445               ze_i_1d(ji,jk,jl) = zswinew(ji)   *   ze_newice(ji) +                                                      & 
    437446                  &        ( 1.0 - zswinew(ji) ) * ( ze_newice(ji) * zv_newice(ji) + ze_i_1d(ji,jk,jl) * zv_b(ji,jl) )  & 
    438447                  &        * rswitch / MAX( zv_i_1d(ji,jl), epsi20 ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r6617 r6625  
    422422            DO jj = 1, jpj 
    423423               DO ji = 1, jpi 
    424                   a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax_2d(ji,jj) ) 
     424                  a_i(ji,jj,1)  = MIN( a_i(ji,jj,1), rn_amax ) 
    425425               END DO 
    426426            END DO 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limupdate1.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limupdate2.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r6617 r6625  
    163163               rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    164164               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    165             END DO 
    166          END DO 
    167       END DO 
    168       ! Force the upper limit of ht_i to always be < hi_max (99 m). 
    169       DO jj = 1, jpj 
    170          DO ji = 1, jpi 
    171             rswitch = MAX( 0._wp , SIGN( 1._wp, ht_i(ji,jj,jpl) - epsi20 ) ) 
    172             ht_i(ji,jj,jpl) = MIN( ht_i(ji,jj,jpl) , hi_max(jpl) ) 
    173             a_i (ji,jj,jpl) = v_i(ji,jj,jpl) / MAX( ht_i(ji,jj,jpl) , epsi20 ) * rswitch 
    174          END DO 
    175       END DO 
    176  
    177       DO jl = 1, jpl 
    178          DO jj = 1, jpj 
    179             DO ji = 1, jpi 
    180                rswitch = MAX( 0._wp , SIGN( 1._wp, a_i(ji,jj,jl) - epsi20 ) )   !0 if no ice and 1 if yes 
    181165               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    182166               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , epsi20 ) * rswitch 
    … …  
    184168         END DO 
    185169      END DO 
    186        
     170 
    187171      IF(  nn_icesal == 2  )THEN 
    188172         DO jl = 1, jpl 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r6617 r6625  
    157157      ENDIF 
    158158 
    159       IF ( iom_use( "icecolf" ) )   CALL iom_put( "icecolf", hicol )  ! frazil ice collection thickness 
     159      IF ( iom_use( "icecolf" ) ) THEN  
     160         DO jj = 1, jpj 
     161            DO ji = 1, jpi 
     162               rswitch  = MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) ) ) 
     163               z2d(ji,jj) = hicol(ji,jj) * rswitch 
     164            END DO 
     165         END DO 
     166         CALL iom_put( "icecolf"     , z2d              )        ! frazil ice collection thickness 
     167      ENDIF 
    160168 
    161169      CALL iom_put( "isst"        , sst_m               )        ! sea surface temperature 
    … …  
    182190      CALL iom_put( "destrp"      , diag_trp_es         )        ! advected snw enthalpy (W/m2) 
    183191 
    184       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 
    187       CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from snow ice formation 
    188       CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from open water formation 
     192      CALL iom_put( "sfxbog"      , sfx_bog * rday      )        ! salt flux from brines 
     193      CALL iom_put( "sfxbom"      , sfx_bom * rday      )        ! salt flux from brines 
     194      CALL iom_put( "sfxsum"      , sfx_sum * rday      )        ! salt flux from brines 
     195      CALL iom_put( "sfxsni"      , sfx_sni * rday      )        ! salt flux from brines 
     196      CALL iom_put( "sfxopw"      , sfx_opw * rday      )        ! salt flux from brines 
    189197      CALL iom_put( "sfxdyn"      , sfx_dyn * rday      )        ! salt flux from ridging rafting 
    190       CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from residual 
     198      CALL iom_put( "sfxres"      , sfx_res * rday      )        ! salt flux from limupdate (resultant) 
    191199      CALL iom_put( "sfxbri"      , sfx_bri * rday      )        ! salt flux from brines 
    192       CALL iom_put( "sfxsub"      , sfx_sub * rday      )        ! salt flux from sublimation 
    193200      CALL iom_put( "sfx"         , sfx     * rday      )        ! total salt flux 
    194201 
    … …  
    228235      CALL iom_put ('hfxdhc'     , diag_heat(:,:)       )   ! Heat content variation in snow and ice  
    229236      CALL iom_put ('hfxspr'     , hfx_spr(:,:)         )   ! Heat content of snow precip  
    230  
    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 
    243237       
    244238      !-------------------------------- 
    … …  
    317311      !! 
    318312      !! History : 
    319       !!   4.0  !  2013-06  (C. Rousset) 
     313      !!   4.1  !  2013-06  (C. Rousset) 
    320314      !!---------------------------------------------------------------------- 
    321315      INTEGER, INTENT( in ) ::   kt               ! ocean time-step index) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/LIM_SRC_3/thd_ice.F90

    r6617 r6625  
    4545   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qns_ice_1d   
    4646   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   t_bo_1d      
    47    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   rn_amax_1d 
    4847 
    4948   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   hfx_sum_1d 
    … …  
    8483   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_res_1d   
    8584 
    86    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sfx_sub_1d 
    87  
    8885   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   sprecip_1d    !: <==> the 2D  sprecip 
    8986   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   frld_1d       !: <==> the 2D  frld 
    … …  
    9491   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   evap_ice_1d   !: <==> the 2D  evap_ice 
    9592   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qprec_ice_1d  !: <==> the 2D  qprec_ice 
    96    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   qevap_ice_1d  !: <==> the 3D  qevap_ice 
    9793   !                                                     ! to reintegrate longwave flux inside the ice thermodynamics 
    9894   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   i0            !: fraction of radiation transmitted to the ice 
    … …  
    111107   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_s_tot      !: Snow accretion/ablation        [m] 
    112108   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_surf     !: Ice surface accretion/ablation [m] 
    113    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_sub      !: Ice surface sublimation [m] 
    114109   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_i_bott     !: Ice bottom accretion/ablation  [m] 
    115110   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) ::   dh_snowice    !: Snow ice formation             [m of ice] 
    … …  
    149144         &      hfx_sum_1d(jpij) , hfx_bom_1d(jpij) ,hfx_bog_1d(jpij) ,    &  
    150145         &      hfx_dif_1d(jpij) , hfx_opw_1d(jpij) ,                      & 
    151          &      rn_amax_1d(jpij) ,                                         & 
    152146         &      hfx_thd_1d(jpij) , hfx_spr_1d(jpij) ,                      & 
    153147         &      hfx_snw_1d(jpij) , hfx_sub_1d(jpij) , hfx_err_1d(jpij) ,   & 
    … …  
    159153         &      wfx_sum_1d(jpij)  , wfx_sni_1d (jpij) , wfx_opw_1d (jpij) , wfx_res_1d(jpij) ,  & 
    160154         &      dqns_ice_1d(jpij) , evap_ice_1d (jpij),                                         & 
    161          &      qprec_ice_1d(jpij), qevap_ice_1d(jpij), i0         (jpij) ,                     &   
     155         &      qprec_ice_1d(jpij), i0         (jpij) ,                                         &   
    162156         &      sfx_bri_1d (jpij) , sfx_bog_1d (jpij) , sfx_bom_1d (jpij) , sfx_sum_1d (jpij),  & 
    163          &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) , sfx_sub_1d (jpij),  & 
     157         &      sfx_sni_1d (jpij) , sfx_opw_1d (jpij) , sfx_res_1d (jpij) ,                     & 
    164158         &      dsm_i_fl_1d(jpij) , dsm_i_gd_1d(jpij) , dsm_i_se_1d(jpij) ,                     &      
    165159         &      dsm_i_si_1d(jpij) , hicol_1d    (jpij)                     , STAT=ierr(2) ) 
    … …  
    167161      ALLOCATE( t_su_1d   (jpij) , a_i_1d   (jpij) , ht_i_1d  (jpij) ,    &    
    168162         &      ht_s_1d   (jpij) , fc_su    (jpij) , fc_bo_i  (jpij) ,    &     
    169          &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_sub (jpij) ,    &     
    170          &      dh_i_bott (jpij) ,dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
     163         &      dh_s_tot  (jpij) , dh_i_surf(jpij) , dh_i_bott(jpij) ,    &     
     164         &      dh_snowice(jpij) , sm_i_1d  (jpij) , s_i_new  (jpij) ,    & 
    171165         &      t_s_1d(jpij,nlay_s) , t_i_1d(jpij,nlay_i) , s_i_1d(jpij,nlay_i) ,  &             
    172166         &      q_i_1d(jpij,nlay_i+1) , q_s_1d(jpij,nlay_s) ,                        & 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif2model.F90

    r6617 r6625  
    11#if defined key_agrif 
    2 !!---------------------------------------------------------------------- 
    3 !! NEMO/NST 3.6 , NEMO Consortium (2010) 
    4 !! $Id$ 
    5 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    6 !!---------------------------------------------------------------------- 
    7 SUBROUTINE Agrif2Model 
    8    !!--------------------------------------------- 
    9    !!   *** ROUTINE Agrif2Model *** 
    10    !!---------------------------------------------  
    11 END SUBROUTINE Agrif2model 
     2   !!---------------------------------------------------------------------- 
     3   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
     4   !! $Id$ 
     5   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     6   !!---------------------------------------------------------------------- 
     7   SUBROUTINE Agrif2Model 
     8      !!--------------------------------------------- 
     9      !!   *** ROUTINE Agrif2Model *** 
     10      !!---------------------------------------------  
     11   END SUBROUTINE Agrif2model 
    1212 
    13 SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
    14    !!--------------------------------------------- 
    15    !!   *** ROUTINE Agrif_Set_numberofcells *** 
    16    !!---------------------------------------------  
    17    USE Agrif_Grids 
    18    IMPLICIT NONE 
     13   SUBROUTINE Agrif_Set_numberofcells(Agrif_Gr) 
     14      !!--------------------------------------------- 
     15      !!   *** ROUTINE Agrif_Set_numberofcells *** 
     16      !!---------------------------------------------  
     17      USE Agrif_Types 
     18      IMPLICIT NONE 
    1919 
    20    TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
     20      Type(Agrif_Grid), Pointer :: Agrif_Gr 
    2121 
    22    IF ( ASSOCIATED(Agrif_Curgrid) )THEN 
     22      IF ( associated(Agrif_Curgrid) )THEN 
    2323#include "SetNumberofcells.h" 
    24    ENDIF 
     24      ENDIF 
    2525 
    26 END SUBROUTINE Agrif_Set_numberofcells 
     26   END SUBROUTINE Agrif_Set_numberofcells 
    2727 
    28 SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
    29    !!--------------------------------------------- 
    30    !!   *** ROUTINE Agrif_Get_numberofcells *** 
    31    !!---------------------------------------------  
    32    USE Agrif_Grids 
    33    IMPLICIT NONE 
     28   SUBROUTINE Agrif_Get_numberofcells(Agrif_Gr) 
     29      !!--------------------------------------------- 
     30      !!   *** ROUTINE Agrif_Get_numberofcells *** 
     31      !!---------------------------------------------  
     32      USE Agrif_Types 
     33      IMPLICIT NONE 
    3434 
    35    TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
     35      Type(Agrif_Grid), Pointer :: Agrif_Gr 
    3636 
    37    IF ( ASSOCIATED(Agrif_Curgrid) ) THEN 
    3837#include "GetNumberofcells.h" 
    39    ENDIF 
    4038 
    41 END SUBROUTINE Agrif_Get_numberofcells 
     39   END SUBROUTINE Agrif_Get_numberofcells 
    4240 
    43 SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
    44    !!--------------------------------------------- 
    45    !!   *** ROUTINE Agrif_Allocationscalls *** 
    46    !!---------------------------------------------  
    47    USE Agrif_Grids  
     41   SUBROUTINE Agrif_Allocationcalls(Agrif_Gr) 
     42      !!--------------------------------------------- 
     43      !!   *** ROUTINE Agrif_Allocationscalls *** 
     44      !!---------------------------------------------  
     45      USE Agrif_Types  
    4846#include "include_use_Alloc_agrif.h" 
    49    IMPLICIT NONE 
     47      IMPLICIT NONE 
    5048 
    51    TYPE(Agrif_Grid), POINTER :: Agrif_Gr 
     49      Type(Agrif_Grid), Pointer :: Agrif_Gr 
    5250 
    5351#include "allocations_calls_agrif.h" 
    5452 
    55 END SUBROUTINE Agrif_Allocationcalls 
     53   END SUBROUTINE Agrif_Allocationcalls 
    5654 
    57 SUBROUTINE Agrif_probdim_modtype_def() 
    58    !!--------------------------------------------- 
    59    !!   *** ROUTINE Agrif_probdim_modtype_def *** 
    60    !!---------------------------------------------  
    61    USE Agrif_Types 
    62    IMPLICIT NONE 
     55   SUBROUTINE Agrif_probdim_modtype_def() 
     56      !!--------------------------------------------- 
     57      !!   *** ROUTINE Agrif_probdim_modtype_def *** 
     58      !!---------------------------------------------  
     59      USE Agrif_Types 
     60      IMPLICIT NONE 
    6361 
    6462#include "modtype_agrif.h" 
    … …  
    6664#include "keys_agrif.h" 
    6765 
    68    RETURN 
     66      Return 
    6967 
    70 END SUBROUTINE Agrif_probdim_modtype_def 
     68   END SUBROUTINE Agrif_probdim_modtype_def 
    7169 
    72 SUBROUTINE Agrif_clustering_def() 
    73    !!--------------------------------------------- 
    74    !!   *** ROUTINE Agrif_clustering_def *** 
    75    !!---------------------------------------------  
    76    IMPLICIT NONE 
     70   SUBROUTINE Agrif_clustering_def() 
     71      !!--------------------------------------------- 
     72      !!   *** ROUTINE Agrif_clustering_def *** 
     73      !!---------------------------------------------  
     74      Use Agrif_Types 
     75      IMPLICIT NONE 
    7776 
    78    RETURN 
     77      Return 
    7978 
    80 END SUBROUTINE Agrif_clustering_def 
     79   END SUBROUTINE Agrif_clustering_def 
    8180 
     81   SUBROUTINE Agrif_comm_def(modelcomm) 
     82 
     83      !!--------------------------------------------- 
     84      !!   *** ROUTINE Agrif_clustering_def *** 
     85      !!---------------------------------------------  
     86      Use Agrif_Types 
     87      Use lib_mpp 
     88 
     89      IMPLICIT NONE 
     90 
     91      INTEGER :: modelcomm 
     92 
     93#if defined key_mpp_mpi 
     94      modelcomm = mpi_comm_opa 
     95#endif 
     96      Return 
     97 
     98   END SUBROUTINE Agrif_comm_def 
    8299#else 
    83 SUBROUTINE Agrif2Model 
    84    !!--------------------------------------------- 
    85    !!   *** ROUTINE Agrif2Model *** 
    86    !!---------------------------------------------  
    87    WRITE(*,*) 'Impossible to bet here' 
    88 END SUBROUTINE Agrif2model 
     100   SUBROUTINE Agrif2Model 
     101      !!--------------------------------------------- 
     102      !!   *** ROUTINE Agrif2Model *** 
     103      !!---------------------------------------------  
     104      WRITE(*,*) 'Impossible to bet here' 
     105   END SUBROUTINE Agrif2model 
    89106#endif 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

    r6617 r6625  
    99   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP 
    1010   !!---------------------------------------------------------------------- 
    11 #if defined key_agrif && defined key_lim2  
     11#if defined key_agrif && defined key_lim2 
    1212   !!---------------------------------------------------------------------- 
    1313   !!   'key_lim2'  :                                 LIM 2.0 sea-ice model 
    … …  
    4141   PUBLIC interp_adv_ice 
    4242 
    43    REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr 
    44    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr  
    45  
    46  
    4743   !!---------------------------------------------------------------------- 
    4844   !! NEMO/NST 3.4 , NEMO Consortium (2012) 
    … …  
    6965      u_ice_nst(:,:) = 0. 
    7066      v_ice_nst(:,:) = 0. 
    71       CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
    72       CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
     67      CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. ) 
     68      CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. ) 
    7369      Agrif_SpecialValue=0. 
    7470      Agrif_UseSpecialValue = .FALSE. 
    … …  
    142138      !!  we are in inside a new parent ice time step 
    143139      !!----------------------------------------------------------------------- 
     140      REAL(wp), DIMENSION(jpi,jpj) :: zuice, zvice 
    144141      INTEGER :: ji,jj 
    145142      REAL(wp) :: zrhox, zrhoy 
    … …  
    158155         Agrif_SpecialValue=-9999. 
    159156         Agrif_UseSpecialValue = .TRUE. 
    160          IF( .NOT. ALLOCATED(uice_agr) )THEN 
    161             ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj)) 
    162          ENDIF 
    163          uice_agr = 0. 
    164          vice_agr = 0. 
    165          CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.) 
    166          CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.) 
     157         zuice = 0. 
     158         zvice = 0. 
     159         CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.) 
     160         CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.) 
    167161         Agrif_SpecialValue=0. 
    168162         Agrif_UseSpecialValue = .FALSE. 
    169163         !   
    170164         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()       
    171          uice_agr(:,:) =  uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
    172          vice_agr(:,:) =  vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
     165         zuice(:,:) =  zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1) 
     166         zvice(:,:) =  zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1) 
    173167         ! fill  boundaries 
    174168         DO jj = 1, jpj 
    175169            DO ji = 1, 2 
    176                u_ice_oe(ji,  jj,2) = uice_agr(ji       ,jj)  
    177                u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj) 
     170               u_ice_oe(ji,  jj,2) = zuice(ji       ,jj)  
     171               u_ice_oe(ji+2,jj,2) = zuice(nlci+ji-3,jj) 
    178172            END DO 
    179173         END DO 
    180174         DO jj = 1, jpj 
    181             v_ice_oe(2,jj,2) = vice_agr(2     ,jj)  
    182             v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj) 
     175            v_ice_oe(2,jj,2) = zvice(2     ,jj)  
     176            v_ice_oe(4,jj,2) = zvice(nlci-1,jj) 
    183177         END DO 
    184178         DO ji = 1, jpi 
    185             u_ice_sn(ji,2,2) = uice_agr(ji,2     )  
    186             u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1) 
     179            u_ice_sn(ji,2,2) = zuice(ji,2     )  
     180            u_ice_sn(ji,4,2) = zuice(ji,nlcj-1) 
    187181         END DO 
    188182         DO jj = 1, 2 
    189183            DO ji = 1, jpi 
    190                v_ice_sn(ji,jj  ,2) = vice_agr(ji,jj       )  
    191                v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3) 
     184               v_ice_sn(ji,jj  ,2) = zvice(ji,jj       )  
     185               v_ice_sn(ji,jj+2,2) = zvice(ji,nlcj+jj-3) 
    192186            END DO 
    193187         END DO 
    … …  
    340334      !!  we are in inside a new parent ice time step 
    341335     !!----------------------------------------------------------------------- 
     336      REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    342337      INTEGER :: ji,jj,jn 
    343338      !!----------------------------------------------------------------------- 
    … …  
    350345         adv_ice_sn(:,:,:,1) =  adv_ice_sn(:,:,:,2) 
    351346         ! interpolation of boundaries 
    352          IF(.NOT.ALLOCATED(tabice_agr))THEN 
    353             ALLOCATE(tabice_agr(jpi,jpj,7))    
    354          ENDIF 
    355          tabice_agr(:,:,:) = 0. 
     347         ztab(:,:,:) = 0. 
    356348         Agrif_SpecialValue=-9999. 
    357349         Agrif_UseSpecialValue = .TRUE. 
    358          CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
     350         CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice,calledweight=1. ) 
    359351         Agrif_SpecialValue=0. 
    360352         Agrif_UseSpecialValue = .FALSE. 
    … …  
    364356            DO jj = 1, jpj 
    365357               DO ji=1,2 
    366                   adv_ice_oe(ji  ,jj,jn,2) = tabice_agr(ji       ,jj,jn)  
    367                   adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn) 
     358                  adv_ice_oe(ji  ,jj,jn,2) = ztab(ji       ,jj,jn)  
     359                  adv_ice_oe(ji+2,jj,jn,2) = ztab(nlci-2+ji,jj,jn) 
    368360               END DO 
    369361            END DO 
    … …  
    373365            Do jj =1,2 
    374366               DO ji = 1, jpi 
    375                   adv_ice_sn(ji,jj  ,jn,2) = tabice_agr(ji,jj       ,jn)  
    376                   adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn) 
     367                  adv_ice_sn(ji,jj  ,jn,2) = ztab(ji,jj       ,jn)  
     368                  adv_ice_sn(ji,jj+2,jn,2) = ztab(ji,nlcj-2+jj,jn) 
    377369               END DO 
    378370            END DO 
    … …  
    392384      INTEGER :: ji,jj,jn 
    393385      REAL(wp) :: zalpha 
    394       REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr  
     386      REAL(wp), DIMENSION(jpi,jpj,7) :: ztab  
    395387      !!-----------------------------------------------------------------------       
    396388      ! 
    … …  
    399391      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc)) 
    400392      ! 
    401       tabice_agr(:,:,:) = 0.e0 
     393      ztab(:,:,:) = 0.e0 
    402394      DO jn =1,7 
    403395         DO jj =1,2 
    404396            DO ji = 1, jpi 
    405                tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
    406                tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
     397               ztab(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2)  
     398               ztab(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2)  
    407399            END DO 
    408400         END DO 
    … …  
    412404         DO jj = 1, jpj 
    413405            DO ji=1,2 
    414                tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
    415                tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
    416             END DO 
    417          END DO 
    418       END DO 
    419       ! 
    420       CALL parcoursT( tabice_agr(:,:, 1), frld  ) 
    421       CALL parcoursT( tabice_agr(:,:, 2), hicif ) 
    422       CALL parcoursT( tabice_agr(:,:, 3), hsnif ) 
    423       CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) ) 
    424       CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) ) 
    425       CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) ) 
    426       CALL parcoursT( tabice_agr(:,:, 7), qstoif ) 
     406               ztab(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2)  
     407               ztab(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2)  
     408            END DO 
     409         END DO 
     410      END DO 
     411      ! 
     412      CALL parcoursT( ztab(:,:, 1), frld  ) 
     413      CALL parcoursT( ztab(:,:, 2), hicif ) 
     414      CALL parcoursT( ztab(:,:, 3), hsnif ) 
     415      CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) ) 
     416      CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) ) 
     417      CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) ) 
     418      CALL parcoursT( ztab(:,:, 7), qstoif ) 
    427419      ! 
    428420   END SUBROUTINE agrif_trp_lim2 
    … …  
    507499 
    508500 
    509    SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before ) 
     501   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 ) 
    510502      !!----------------------------------------------------------------------- 
    511503      !!                     *** ROUTINE interp_u_ice *** 
    … …  
    513505      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    514506      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    515       LOGICAL, INTENT(in) :: before 
    516507      !! 
    517508      INTEGER :: ji,jj 
    … …  
    519510      ! 
    520511#if defined key_lim2_vp 
    521       IF( before ) THEN 
    522          DO jj=MAX(j1,2),j2 
    523             DO ji=MAX(i1,2),i2 
    524                IF( tmu(ji,jj) == 0. ) THEN 
    525                   tabres(ji,jj) = -9999. 
    526                ELSE 
    527                   tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
    528                ENDIF 
    529             END DO 
    530          END DO 
    531       ENDIF 
     512      DO jj=MAX(j1,2),j2 
     513         DO ji=MAX(i1,2),i2 
     514            IF( tmu(ji,jj) == 0. ) THEN 
     515               tabres(ji,jj) = -9999. 
     516            ELSE 
     517               tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj) 
     518            ENDIF 
     519         END DO 
     520      END DO 
    532521#else 
    533       IF( before ) THEN 
    534          DO jj= j1, j2 
    535             DO ji= i1, i2 
    536                IF( umask(ji,jj,1) == 0. ) THEN 
    537                   tabres(ji,jj) = -9999. 
    538                ELSE 
    539                   tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
    540                ENDIF 
    541             END DO 
    542          END DO 
    543       ENDIF 
     522      DO jj= j1, j2 
     523         DO ji= i1, i2 
     524            IF( umask(ji,jj,1) == 0. ) THEN 
     525               tabres(ji,jj) = -9999. 
     526            ELSE 
     527               tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj) 
     528            ENDIF 
     529         END DO 
     530      END DO 
    544531#endif 
    545532   END SUBROUTINE interp_u_ice 
    546533 
    547534 
    548    SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before ) 
     535   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 ) 
    549536      !!----------------------------------------------------------------------- 
    550537      !!                    *** ROUTINE interp_v_ice *** 
    … …  
    552539      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    553540      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    554       LOGICAL, INTENT(in) :: before 
    555541      !! 
    556542      INTEGER :: ji, jj 
    … …  
    558544      ! 
    559545#if defined key_lim2_vp 
    560       IF( before ) THEN 
    561          DO jj=MAX(j1,2),j2 
    562             DO ji=MAX(i1,2),i2 
    563                IF( tmu(ji,jj) == 0. ) THEN 
    564                   tabres(ji,jj) = -9999. 
    565                ELSE 
    566                   tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
    567                ENDIF 
    568             END DO 
    569          END DO 
    570       ENDIF    
     546      DO jj=MAX(j1,2),j2 
     547         DO ji=MAX(i1,2),i2 
     548            IF( tmu(ji,jj) == 0. ) THEN 
     549               tabres(ji,jj) = -9999. 
     550            ELSE 
     551               tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj) 
     552            ENDIF 
     553         END DO 
     554      END DO 
    571555#else 
    572       IF( before ) THEN 
    573          DO jj= j1 ,j2 
    574             DO ji = i1, i2 
    575                IF( vmask(ji,jj,1) == 0. ) THEN 
    576                   tabres(ji,jj) = -9999. 
    577                ELSE 
    578                   tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
    579                ENDIF 
    580             END DO 
    581          END DO 
    582       ENDIF 
     556      DO jj= j1 ,j2 
     557         DO ji = i1, i2 
     558            IF( vmask(ji,jj,1) == 0. ) THEN 
     559               tabres(ji,jj) = -9999. 
     560            ELSE 
     561               tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj) 
     562            ENDIF 
     563         END DO 
     564      END DO 
    583565#endif 
    584566   END SUBROUTINE interp_v_ice 
    585567 
    586568 
    587    SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before ) 
     569   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 ) 
    588570      !!----------------------------------------------------------------------- 
    589571      !!                    *** ROUTINE interp_adv_ice ***                            
    … …  
    595577      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    596578      REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres 
    597       LOGICAL, INTENT(in) :: before 
    598579      !! 
    599580      INTEGER :: ji, jj, jk 
    600581      !!----------------------------------------------------------------------- 
    601582      ! 
    602       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 
    618       ENDIF 
     583      DO jj=j1,j2 
     584         DO ji=i1,i2 
     585            IF( tms(ji,jj) == 0. ) THEN 
     586               tabres(ji,jj,:) = -9999.  
     587            ELSE 
     588               tabres(ji,jj, 1) = frld  (ji,jj) 
     589               tabres(ji,jj, 2) = hicif (ji,jj) 
     590               tabres(ji,jj, 3) = hsnif (ji,jj) 
     591               tabres(ji,jj, 4) = tbif  (ji,jj,1) 
     592               tabres(ji,jj, 5) = tbif  (ji,jj,2) 
     593               tabres(ji,jj, 6) = tbif  (ji,jj,3) 
     594               tabres(ji,jj, 7) = qstoif(ji,jj) 
     595            ENDIF 
     596         END DO 
     597      END DO 
    619598      ! 
    620599   END SUBROUTINE interp_adv_ice 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_lim2_update.F90

    r6617 r6625  
    5252      INTEGER, INTENT(in) :: kt 
    5353      !! 
     54      REAL(wp), DIMENSION(jpi,jpj)  :: zvel 
     55      REAL(wp), DIMENSION(jpi,jpj,7):: zadv 
    5456      !!---------------------------------------------------------------------- 
    5557      ! 
    … …  
    5860      Agrif_UseSpecialValueInUpdate = .TRUE. 
    5961      Agrif_SpecialValueFineGrid = 0. 
     62 
    6063# if defined TWO_WAY 
    6164      IF( MOD(nbcline,nbclineupdate) == 0) THEN 
    62          CALL Agrif_Update_Variable( adv_ice_id , procname = update_adv_ice  ) 
    63          CALL Agrif_Update_Variable( u_ice_id   , procname = update_u_ice    ) 
    64          CALL Agrif_Update_Variable( v_ice_id   , procname = update_v_ice    ) 
    65       ELSE 
    66          CALL Agrif_Update_Variable( adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
    67          CALL Agrif_Update_Variable( u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
    68          CALL Agrif_Update_Variable( v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
     65         CALL Agrif_Update_Variable( zadv , adv_ice_id , procname = update_adv_ice  ) 
     66         CALL Agrif_Update_Variable( zvel , u_ice_id   , procname = update_u_ice    ) 
     67         CALL Agrif_Update_Variable( zvel , v_ice_id   , procname = update_v_ice    ) 
     68      ELSE 
     69         CALL Agrif_Update_Variable( zadv , adv_ice_id , locupdate=(/0,2/), procname = update_adv_ice  ) 
     70         CALL Agrif_Update_Variable( zvel , u_ice_id   , locupdate=(/0,1/), procname = update_u_ice    ) 
     71         CALL Agrif_Update_Variable( zvel , v_ice_id   , locupdate=(/0,1/), procname = update_v_ice    ) 
    6972      ENDIF 
    7073# endif 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_oce.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90

    r6617 r6625  
    77   !!             -   !  2005-11  (XXX)  
    88   !!            3.2  !  2009-04  (R. Benshila)  
    9    !!            3.6  !  2014-09  (R. Benshila)  
    109   !!---------------------------------------------------------------------- 
    1110#if defined key_agrif && ! defined key_offline 
    … …  
    3029   USE wrk_nemo 
    3130   USE dynspg_oce 
    32    USE zdf_oce 
    33   
     31 
    3432   IMPLICIT NONE 
    3533   PRIVATE 
    3634 
    37    INTEGER :: bdy_tinterp = 0 
    38  
     35   ! Barotropic arrays used to store open boundary data during 
     36   ! time-splitting loop: 
     37   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_w, vbdy_w, hbdy_w 
     38   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_e, vbdy_e, hbdy_e 
     39   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_n, vbdy_n, hbdy_n 
     40   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) ::  ubdy_s, vbdy_s, hbdy_s 
     41     
    3942   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts 
    40    PUBLIC   interpun, interpvn, interpun2d, interpvn2d  
    41    PUBLIC   interptsn,  interpsshn 
    42    PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b 
    43    PUBLIC   interpe3t, interpumsk, interpvmsk 
    44 # if defined key_zdftke 
    45    PUBLIC   Agrif_tke, interpavm 
    46 # endif 
     43   PUBLIC   interpu, interpv, interpunb, interpvnb, interpsshn 
    4744 
    4845#  include "domzgr_substitute.h90"   
    4946#  include "vectopt_loop_substitute.h90" 
    5047   !!---------------------------------------------------------------------- 
    51    !! NEMO/NST 3.6 , NEMO Consortium (2010) 
     48   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    5249   !! $Id$ 
    5350   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    5451   !!---------------------------------------------------------------------- 
    5552 
    56 CONTAINS 
    57  
     53   CONTAINS 
     54    
    5855   SUBROUTINE Agrif_tra 
    5956      !!---------------------------------------------------------------------- 
    60       !!                  ***  ROUTINE Agrif_tra  *** 
     57      !!                  ***  ROUTINE Agrif_Tra  *** 
     58      !!---------------------------------------------------------------------- 
     59      !! 
     60      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
     61      REAL(wp) ::   zrhox , alpha1, alpha2, alpha3 
     62      REAL(wp) ::   alpha4, alpha5, alpha6, alpha7 
     63      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztsa 
    6164      !!---------------------------------------------------------------------- 
    6265      ! 
    6366      IF( Agrif_Root() )   RETURN 
    6467 
     68      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztsa )  
     69 
    6570      Agrif_SpecialValue    = 0.e0 
    6671      Agrif_UseSpecialValue = .TRUE. 
    67  
    68       CALL Agrif_Bc_variable( tsn_id, procname=interptsn ) 
     72      ztsa(:,:,:,:) = 0.e0 
     73 
     74      CALL Agrif_Bc_variable( ztsa, tsn_id, procname=interptsn ) 
    6975      Agrif_UseSpecialValue = .FALSE. 
     76 
     77      zrhox = Agrif_Rhox() 
     78 
     79      alpha1 = ( zrhox - 1. ) * 0.5 
     80      alpha2 = 1. - alpha1 
     81 
     82      alpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
     83      alpha4 = 1. - alpha3 
     84 
     85      alpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
     86      alpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
     87      alpha5 = 1. - alpha6 - alpha7 
     88 
     89      IF( nbondi == 1 .OR. nbondi == 2 ) THEN 
     90 
     91         DO jn = 1, jpts 
     92            tsa(nlci,:,:,jn) = alpha1 * ztsa(nlci,:,:,jn) + alpha2 * ztsa(nlci-1,:,:,jn) 
     93            DO jk = 1, jpkm1 
     94               DO jj = 1, jpj 
     95                  IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
     96                     tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
     97                  ELSE 
     98                     tsa(nlci-1,jj,jk,jn)=(alpha4*tsa(nlci,jj,jk,jn)+alpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
     99                     IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
     100                        tsa(nlci-1,jj,jk,jn)=( alpha6*tsa(nlci-2,jj,jk,jn)+alpha5*tsa(nlci,jj,jk,jn)  & 
     101                           &                 + alpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
     102                     ENDIF 
     103                  ENDIF 
     104               END DO 
     105            END DO 
     106         ENDDO 
     107      ENDIF 
     108 
     109      IF( nbondj == 1 .OR. nbondj == 2 ) THEN 
     110 
     111         DO jn = 1, jpts 
     112            tsa(:,nlcj,:,jn) = alpha1 * ztsa(:,nlcj,:,jn) + alpha2 * ztsa(:,nlcj-1,:,jn) 
     113            DO jk = 1, jpkm1 
     114               DO ji = 1, jpi 
     115                  IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
     116                     tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
     117                  ELSE 
     118                     tsa(ji,nlcj-1,jk,jn)=(alpha4*tsa(ji,nlcj,jk,jn)+alpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
     119                     IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
     120                        tsa(ji,nlcj-1,jk,jn)=( alpha6*tsa(ji,nlcj-2,jk,jn)+alpha5*tsa(ji,nlcj,jk,jn)  & 
     121                           &                 + alpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
     122                     ENDIF 
     123                  ENDIF 
     124               END DO 
     125            END DO 
     126         ENDDO  
     127      ENDIF 
     128 
     129      IF( nbondi == -1 .OR. nbondi == 2 ) THEN 
     130         DO jn = 1, jpts 
     131            tsa(1,:,:,jn) = alpha1 * ztsa(1,:,:,jn) + alpha2 * ztsa(2,:,:,jn) 
     132            DO jk = 1, jpkm1 
     133               DO jj = 1, jpj 
     134                  IF( umask(2,jj,jk) == 0.e0 ) THEN 
     135                     tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
     136                  ELSE 
     137                     tsa(2,jj,jk,jn)=(alpha4*tsa(1,jj,jk,jn)+alpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
     138                     IF( un(2,jj,jk) < 0.e0 ) THEN 
     139                        tsa(2,jj,jk,jn)=(alpha6*tsa(3,jj,jk,jn)+alpha5*tsa(1,jj,jk,jn)+alpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
     140                     ENDIF 
     141                  ENDIF 
     142               END DO 
     143            END DO 
     144         END DO 
     145      ENDIF 
     146 
     147      IF( nbondj == -1 .OR. nbondj == 2 ) THEN 
     148         DO jn = 1, jpts 
     149            tsa(:,1,:,jn) = alpha1 * ztsa(:,1,:,jn) + alpha2 * ztsa(:,2,:,jn) 
     150            DO jk=1,jpk       
     151               DO ji=1,jpi 
     152                  IF( vmask(ji,2,jk) == 0.e0 ) THEN 
     153                     tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
     154                  ELSE 
     155                     tsa(ji,2,jk,jn)=(alpha4*tsa(ji,1,jk,jn)+alpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
     156                     IF( vn(ji,2,jk) < 0.e0 ) THEN 
     157                        tsa(ji,2,jk,jn)=(alpha6*tsa(ji,3,jk,jn)+alpha5*tsa(ji,1,jk,jn)+alpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
     158                     ENDIF 
     159                  ENDIF 
     160               END DO 
     161            END DO 
     162         ENDDO 
     163      ENDIF 
     164      ! 
     165      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztsa )  
    70166      ! 
    71167   END SUBROUTINE Agrif_tra 
    … …  
    79175      INTEGER, INTENT(in) ::   kt 
    80176      !! 
    81       INTEGER :: ji,jj,jk, j1,j2, i1,i2 
     177      INTEGER :: ji,jj,jk 
    82178      REAL(wp) :: timeref 
    83179      REAL(wp) :: z2dt, znugdt 
    84180      REAL(wp) :: zrhox, zrhoy 
    85       REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1 
     181      REAL(wp), POINTER, DIMENSION(:,:,:) :: zua, zva 
     182      REAL(wp), POINTER, DIMENSION(:,:) :: spgv1, spgu1, zua2d, zva2d 
    86183      !!----------------------------------------------------------------------   
    87184 
    88185      IF( Agrif_Root() )   RETURN 
    89186 
    90       CALL wrk_alloc( jpi, jpj, spgv1, spgu1 ) 
    91  
    92       Agrif_SpecialValue=0. 
    93       Agrif_UseSpecialValue = ln_spc_dyn 
    94  
    95       CALL Agrif_Bc_variable(un_interp_id,procname=interpun) 
    96       CALL Agrif_Bc_variable(vn_interp_id,procname=interpvn) 
    97  
    98 #if defined key_dynspg_flt 
    99       CALL Agrif_Bc_variable(e1u_id,calledweight=1., procname=interpun2d) 
    100       CALL Agrif_Bc_variable(e2v_id,calledweight=1., procname=interpvn2d) 
    101 #endif 
    102  
    103       Agrif_UseSpecialValue = .FALSE. 
     187      CALL wrk_alloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
     188      CALL wrk_alloc( jpi, jpj, jpk, zua, zva ) 
    104189 
    105190      zrhox = Agrif_Rhox() 
    … …  
    107192 
    108193      timeref = 1. 
     194 
    109195      ! time step: leap-frog 
    110196      z2dt = 2. * rdt 
    … …  
    114200      znugdt =  grav * z2dt     
    115201 
    116       ! prevent smoothing in ghost cells 
    117       i1=1 
    118       i2=jpi 
    119       j1=1 
    120       j2=jpj 
    121       IF((nbondj == -1).OR.(nbondj == 2)) j1 = 3 
    122       IF((nbondj == +1).OR.(nbondj == 2)) j2 = nlcj-2 
    123       IF((nbondi == -1).OR.(nbondi == 2)) i1 = 3 
    124       IF((nbondi == +1).OR.(nbondi == 2)) i2 = nlci-2 
     202      Agrif_SpecialValue=0. 
     203      Agrif_UseSpecialValue = ln_spc_dyn 
     204 
     205      zua = 0. 
     206      zva = 0. 
     207      CALL Agrif_Bc_variable(zua,un_id,procname=interpu) 
     208      CALL Agrif_Bc_variable(zva,vn_id,procname=interpv) 
     209      zua2d = 0. 
     210      zva2d = 0. 
     211 
     212#if defined key_dynspg_flt 
     213      Agrif_SpecialValue=0. 
     214      Agrif_UseSpecialValue = ln_spc_dyn 
     215      CALL Agrif_Bc_variable(zua2d,e1u_id,calledweight=1.,procname=interpu2d) 
     216      CALL Agrif_Bc_variable(zva2d,e2v_id,calledweight=1.,procname=interpv2d) 
     217#endif 
     218      Agrif_UseSpecialValue = .FALSE. 
    125219 
    126220 
    127221      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     222 
    128223#if defined key_dynspg_flt 
    129          DO jk=1,jpkm1 
    130             DO jj=j1,j2 
     224         DO jj=1,jpj 
     225            laplacu(2,jj) = timeref * (zua2d(2,jj)/(zrhoy*e2u(2,jj)))*umask(2,jj,1) 
     226         END DO 
     227#endif 
     228 
     229         DO jk=1,jpkm1 
     230            DO jj=1,jpj 
     231               ua(1:2,jj,jk) = (zua(1:2,jj,jk)/(zrhoy*e2u(1:2,jj))) 
     232               ua(1:2,jj,jk) = ua(1:2,jj,jk) / fse3u_a(1:2,jj,jk) 
     233            END DO 
     234         END DO 
     235 
     236#if defined key_dynspg_flt 
     237         DO jk=1,jpkm1 
     238            DO jj=1,jpj 
    131239               ua(2,jj,jk) = (ua(2,jj,jk) - z2dt * znugdt * laplacu(2,jj))*umask(2,jj,jk) 
    132240            END DO 
    … …  
    137245         DO jk=1,jpkm1 
    138246            DO jj=1,jpj 
    139                spgu(2,jj)=spgu(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
     247               spgu(2,jj)=spgu(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
    140248            END DO 
    141249         END DO 
    … …  
    143251         DO jj=1,jpj 
    144252            IF (umask(2,jj,1).NE.0.) THEN 
    145                spgu(2,jj)=spgu(2,jj)/hu(2,jj) 
     253               spgu(2,jj)=spgu(2,jj)*hur_a(2,jj) 
    146254            ENDIF 
    147255         END DO 
    … …  
    151259 
    152260         DO jk=1,jpkm1 
    153             DO jj=j1,j2 
     261            DO jj=1,jpj 
    154262               ua(2,jj,jk) = 0.25*(ua(1,jj,jk)+2.*ua(2,jj,jk)+ua(3,jj,jk)) 
    155263               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk) 
    … …  
    161269         DO jk=1,jpkm1 
    162270            DO jj=1,jpj 
    163                spgu1(2,jj)=spgu1(2,jj)+fse3u(2,jj,jk)*ua(2,jj,jk) 
     271               spgu1(2,jj)=spgu1(2,jj)+fse3u_a(2,jj,jk)*ua(2,jj,jk) 
    164272            END DO 
    165273         END DO 
    … …  
    167275         DO jj=1,jpj 
    168276            IF (umask(2,jj,1).NE.0.) THEN 
    169                spgu1(2,jj)=spgu1(2,jj)/hu(2,jj) 
     277               spgu1(2,jj)=spgu1(2,jj)*hur_a(2,jj) 
    170278            ENDIF 
    171279         END DO 
    172280 
    173281         DO jk=1,jpkm1 
    174             DO jj=j1,j2 
     282            DO jj=1,jpj 
    175283               ua(2,jj,jk) = (ua(2,jj,jk)+spgu(2,jj)-spgu1(2,jj))*umask(2,jj,jk) 
     284            END DO 
     285         END DO 
     286 
     287         DO jk=1,jpkm1 
     288            DO jj=1,jpj 
     289               va(2,jj,jk) = (zva(2,jj,jk)/(zrhox*e1v(2,jj)))*vmask(2,jj,jk) 
     290               va(2,jj,jk) = va(2,jj,jk) / fse3v_a(2,jj,jk) 
    176291            END DO 
    177292         END DO 
    … …  
    185300            END DO 
    186301         END DO 
     302 
    187303         DO jj=1,jpj 
    188304            spgv1(2,jj)=spgv1(2,jj)*hvr_a(2,jj) 
    189305         END DO 
     306 
    190307         DO jk=1,jpkm1 
    191308            DO jj=1,jpj 
    … …  
    199316      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    200317#if defined key_dynspg_flt 
    201          DO jk=1,jpkm1 
    202             DO jj=j1,j2 
     318         DO jj=1,jpj 
     319            laplacu(nlci-2,jj) = timeref * (zua2d(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj))) 
     320         END DO 
     321#endif 
     322 
     323         DO jk=1,jpkm1 
     324            DO jj=1,jpj 
     325               ua(nlci-2:nlci-1,jj,jk) = (zua(nlci-2:nlci-1,jj,jk)/(zrhoy*e2u(nlci-2:nlci-1,jj))) 
     326               ua(nlci-2:nlci-1,jj,jk) = ua(nlci-2:nlci-1,jj,jk) / fse3u_a(nlci-2:nlci-1,jj,jk) 
     327            END DO 
     328         END DO 
     329 
     330#if defined key_dynspg_flt 
     331         DO jk=1,jpkm1 
     332            DO jj=1,jpj 
    203333               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)- z2dt * znugdt * laplacu(nlci-2,jj))*umask(nlci-2,jj,jk) 
    204334            END DO 
    205335         END DO 
     336 
     337 
    206338         spgu(nlci-2,:)=0. 
    207          DO jk=1,jpkm1 
    208             DO jj=1,jpj 
    209                spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
    210             ENDDO 
    211          ENDDO 
     339 
     340         do jk=1,jpkm1 
     341            do jj=1,jpj 
     342               spgu(nlci-2,jj)=spgu(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk) 
     343            enddo 
     344         enddo 
     345 
    212346         DO jj=1,jpj 
    213347            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    214                spgu(nlci-2,jj)=spgu(nlci-2,jj)/hu(nlci-2,jj) 
     348               spgu(nlci-2,jj)=spgu(nlci-2,jj)*hur_a(nlci-2,jj) 
    215349            ENDIF 
    216350         END DO 
    … …  
    218352         spgu(nlci-2,:) = ua_b(nlci-2,:) 
    219353#endif 
    220          DO jk=1,jpkm1 
    221             DO jj=j1,j2 
     354 
     355         DO jk=1,jpkm1 
     356            DO jj=1,jpj 
    222357               ua(nlci-2,jj,jk) = 0.25*(ua(nlci-3,jj,jk)+2.*ua(nlci-2,jj,jk)+ua(nlci-1,jj,jk)) 
    223358 
    … …  
    226361            END DO 
    227362         END DO 
     363 
    228364         spgu1(nlci-2,:)=0. 
    229          DO jk=1,jpkm1 
    230             DO jj=1,jpj 
    231                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
    232             END DO 
    233          END DO 
     365 
     366         DO jk=1,jpkm1 
     367            DO jj=1,jpj 
     368               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)+fse3u_a(nlci-2,jj,jk)*ua(nlci-2,jj,jk)*umask(nlci-2,jj,jk) 
     369            END DO 
     370         END DO 
     371 
    234372         DO jj=1,jpj 
    235373            IF (umask(nlci-2,jj,1).NE.0.) THEN 
    236                spgu1(nlci-2,jj)=spgu1(nlci-2,jj)/hu(nlci-2,jj) 
     374               spgu1(nlci-2,jj)=spgu1(nlci-2,jj)*hur_a(nlci-2,jj) 
    237375            ENDIF 
    238376         END DO 
    239          DO jk=1,jpkm1 
    240             DO jj=j1,j2 
     377 
     378         DO jk=1,jpkm1 
     379            DO jj=1,jpj 
    241380               ua(nlci-2,jj,jk) = (ua(nlci-2,jj,jk)+spgu(nlci-2,jj)-spgu1(nlci-2,jj))*umask(nlci-2,jj,jk) 
     381            END DO 
     382         END DO 
     383 
     384         DO jk=1,jpkm1 
     385            DO jj=1,jpj-1 
     386               va(nlci-1,jj,jk) = (zva(nlci-1,jj,jk)/(zrhox*e1v(nlci-1,jj)))*vmask(nlci-1,jj,jk) 
     387               va(nlci-1,jj,jk) = va(nlci-1,jj,jk) / fse3v_a(nlci-1,jj,jk) 
    242388            END DO 
    243389         END DO 
    … …  
    268414 
    269415#if defined key_dynspg_flt 
     416         DO ji=1,jpi 
     417            laplacv(ji,2) = timeref * (zva2d(ji,2)/(zrhox*e1v(ji,2))) 
     418         END DO 
     419#endif 
     420 
     421         DO jk=1,jpkm1 
     422            DO ji=1,jpi 
     423               va(ji,1:2,jk) = (zva(ji,1:2,jk)/(zrhox*e1v(ji,1:2))) 
     424               va(ji,1:2,jk) = va(ji,1:2,jk) / fse3v_a(ji,1:2,jk) 
     425            END DO 
     426         END DO 
     427 
     428#if defined key_dynspg_flt 
    270429         DO jk=1,jpkm1 
    271430            DO ji=1,jpi 
    … …  
    278437         DO jk=1,jpkm1 
    279438            DO ji=1,jpi 
    280                spgv(ji,2)=spgv(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk) 
     439               spgv(ji,2)=spgv(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk) 
    281440            END DO 
    282441         END DO 
    … …  
    284443         DO ji=1,jpi 
    285444            IF (vmask(ji,2,1).NE.0.) THEN 
    286                spgv(ji,2)=spgv(ji,2)/hv(ji,2) 
     445               spgv(ji,2)=spgv(ji,2)*hvr_a(ji,2) 
    287446            ENDIF 
    288447         END DO 
    … …  
    292451 
    293452         DO jk=1,jpkm1 
    294             DO ji=i1,i2 
     453            DO ji=1,jpi 
    295454               va(ji,2,jk)=0.25*(va(ji,1,jk)+2.*va(ji,2,jk)+va(ji,3,jk)) 
    296455               va(ji,2,jk)=va(ji,2,jk)*vmask(ji,2,jk) 
    … …  
    302461         DO jk=1,jpkm1 
    303462            DO ji=1,jpi 
    304                spgv1(ji,2)=spgv1(ji,2)+fse3v(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
     463               spgv1(ji,2)=spgv1(ji,2)+fse3v_a(ji,2,jk)*va(ji,2,jk)*vmask(ji,2,jk) 
    305464            END DO 
    306465         END DO 
    … …  
    308467         DO ji=1,jpi 
    309468            IF (vmask(ji,2,1).NE.0.) THEN 
    310                spgv1(ji,2)=spgv1(ji,2)/hv(ji,2) 
     469               spgv1(ji,2)=spgv1(ji,2)*hvr_a(ji,2) 
    311470            ENDIF 
    312471         END DO 
    … …  
    315474            DO ji=1,jpi 
    316475               va(ji,2,jk) = (va(ji,2,jk)+spgv(ji,2)-spgv1(ji,2))*vmask(ji,2,jk) 
     476            END DO 
     477         END DO 
     478 
     479         DO jk=1,jpkm1 
     480            DO ji=1,jpi 
     481               ua(ji,2,jk) = (zua(ji,2,jk)/(zrhoy*e2u(ji,2)))*umask(ji,2,jk)  
     482               ua(ji,2,jk) = ua(ji,2,jk) / fse3u_a(ji,2,jk) 
    317483            END DO 
    318484         END DO 
    … …  
    342508 
    343509#if defined key_dynspg_flt 
     510         DO ji=1,jpi 
     511            laplacv(ji,nlcj-2) = timeref * (zva2d(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2))) 
     512         END DO 
     513#endif 
     514 
     515         DO jk=1,jpkm1 
     516            DO ji=1,jpi 
     517               va(ji,nlcj-2:nlcj-1,jk) = (zva(ji,nlcj-2:nlcj-1,jk)/(zrhox*e1v(ji,nlcj-2:nlcj-1))) 
     518               va(ji,nlcj-2:nlcj-1,jk) = va(ji,nlcj-2:nlcj-1,jk) / fse3v_a(ji,nlcj-2:nlcj-1,jk) 
     519            END DO 
     520         END DO 
     521 
     522#if defined key_dynspg_flt 
    344523         DO jk=1,jpkm1 
    345524            DO ji=1,jpi 
    … …  
    348527         END DO 
    349528 
    350  
    351529         spgv(:,nlcj-2)=0. 
    352530 
    353531         DO jk=1,jpkm1 
    354532            DO ji=1,jpi 
    355                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     533               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    356534            END DO 
    357535         END DO 
    … …  
    359537         DO ji=1,jpi 
    360538            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    361                spgv(ji,nlcj-2)=spgv(ji,nlcj-2)/hv(ji,nlcj-2) 
     539               spgv(ji,nlcj-2)=spgv(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    362540            ENDIF 
    363541         END DO 
    364  
    365542#else 
    366543         spgv(:,nlcj-2)=va_b(:,nlcj-2) 
    … …  
    368545 
    369546         DO jk=1,jpkm1 
    370             DO ji=i1,i2 
     547            DO ji=1,jpi 
    371548               va(ji,nlcj-2,jk)=0.25*(va(ji,nlcj-3,jk)+2.*va(ji,nlcj-2,jk)+va(ji,nlcj-1,jk)) 
    372549               va(ji,nlcj-2,jk) = va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk) 
    … …  
    378555         DO jk=1,jpkm1 
    379556            DO ji=1,jpi 
    380                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
     557               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)+fse3v_a(ji,nlcj-2,jk)*va(ji,nlcj-2,jk) 
    381558            END DO 
    382559         END DO 
    … …  
    384561         DO ji=1,jpi 
    385562            IF (vmask(ji,nlcj-2,1).NE.0.) THEN 
    386                spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)/hv(ji,nlcj-2) 
     563               spgv1(ji,nlcj-2)=spgv1(ji,nlcj-2)*hvr_a(ji,nlcj-2) 
    387564            ENDIF 
    388565         END DO 
    … …  
    391568            DO ji=1,jpi 
    392569               va(ji,nlcj-2,jk) = (va(ji,nlcj-2,jk)+spgv(ji,nlcj-2)-spgv1(ji,nlcj-2))*vmask(ji,nlcj-2,jk) 
     570            END DO 
     571         END DO 
     572 
     573         DO jk=1,jpkm1 
     574            DO ji=1,jpi 
     575               ua(ji,nlcj-1,jk) = (zua(ji,nlcj-1,jk)/(zrhoy*e2u(ji,nlcj-1)))*umask(ji,nlcj-1,jk) 
     576               ua(ji,nlcj-1,jk) = ua(ji,nlcj-1,jk) / fse3u_a(ji,nlcj-1,jk) 
    393577            END DO 
    394578         END DO 
    … …  
    416600      ENDIF 
    417601      ! 
    418       CALL wrk_dealloc( jpi, jpj, spgv1, spgu1 ) 
     602      CALL wrk_dealloc( jpi, jpj, spgv1, spgu1, zua2d, zva2d ) 
     603      CALL wrk_dealloc( jpi, jpj, jpk, zua, zva ) 
    419604      ! 
    420605   END SUBROUTINE Agrif_dyn 
    … …  
    435620         DO jj=1,jpj 
    436621            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj) 
    437             ! Specified fluxes: 
     622! Specified fluxes: 
    438623            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj) 
    439             ! Characteristics method: 
    440             !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
    441             !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
     624! Characteristics method: 
     625!alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) & 
     626!alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) ) 
    442627         END DO 
    443628      ENDIF 
    … …  
    446631         DO jj=1,jpj 
    447632            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj) 
    448             ! Specified fluxes: 
     633! Specified fluxes: 
    449634            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj) 
    450             ! Characteristics method: 
    451             !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
    452             !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
     635! Characteristics method: 
     636!alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) & 
     637!alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) ) 
    453638         END DO 
    454639      ENDIF 
    … …  
    457642         DO ji=1,jpi 
    458643            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2) 
    459             ! Specified fluxes: 
     644! Specified fluxes: 
    460645            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2) 
    461             ! Characteristics method: 
    462             !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
    463             !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
     646! Characteristics method: 
     647!alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) & 
     648!alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) ) 
    464649         END DO 
    465650      ENDIF 
    … …  
    468653         DO ji=1,jpi 
    469654            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1) 
    470             ! Specified fluxes: 
     655! Specified fluxes: 
    471656            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2) 
    472             ! Characteristics method: 
    473             !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
    474             !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
     657! Characteristics method: 
     658!alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) & 
     659!alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) ) 
    475660         END DO 
    476661      ENDIF 
    … …  
    487672      INTEGER :: ji, jj 
    488673      LOGICAL :: ll_int_cons 
    489       REAL(wp) :: zrhot, zt 
     674      REAL(wp) :: zrhox, zrhoy, zrhot, zt 
     675      REAL(wp) :: zaa, zab, zat 
     676      REAL(wp) :: zt0, zt1 
     677      REAL(wp), POINTER, DIMENSION(:,:) :: zunb, zvnb, zsshn 
     678      REAL(wp), POINTER, DIMENSION(:,:) :: zuab, zvab, zubb, zvbb, zutn, zvtn 
    490679      !!----------------------------------------------------------------------   
    491680 
    … …  
    493682 
    494683      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in 
    495       ! the forward case only 
    496  
     684                             ! the forward case only 
     685 
     686      zrhox = Agrif_Rhox() 
     687      zrhoy = Agrif_Rhoy() 
    497688      zrhot = Agrif_rhot() 
     689 
     690      IF ( kt==nit000 ) THEN ! Allocate boundary data arrays 
     691         ALLOCATE( ubdy_w(jpj), vbdy_w(jpj), hbdy_w(jpj)) 
     692         ALLOCATE( ubdy_e(jpj), vbdy_e(jpj), hbdy_e(jpj)) 
     693         ALLOCATE( ubdy_n(jpi), vbdy_n(jpi), hbdy_n(jpi)) 
     694         ALLOCATE( ubdy_s(jpi), vbdy_s(jpi), hbdy_s(jpi)) 
     695      ENDIF 
     696 
     697      CALL wrk_alloc( jpi, jpj, zunb, zvnb, zsshn ) 
    498698 
    499699      ! "Central" time index for interpolation: 
    … …  
    507707      Agrif_SpecialValue    = 0.e0 
    508708      Agrif_UseSpecialValue = .TRUE. 
    509       CALL Agrif_Bc_variable(sshn_id,calledweight=zt, procname=interpsshn ) 
     709      CALL Agrif_Bc_variable(zsshn, sshn_id,calledweight=zt, procname=interpsshn ) 
    510710      Agrif_UseSpecialValue = .FALSE. 
    511711 
    … …  
    515715 
    516716      IF (ll_int_cons) THEN ! Conservative interpolation 
    517          ! orders matters here !!!!!! 
    518          CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1._wp, procname=interpub2b) ! Time integrated 
    519          CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1._wp, procname=interpvb2b) 
    520          bdy_tinterp = 1 
    521          CALL Agrif_Bc_variable(unb_id ,calledweight=1._wp, procname=interpunb) ! After 
    522          CALL Agrif_Bc_variable(vnb_id ,calledweight=1._wp, procname=interpvnb) 
    523          bdy_tinterp = 2 
    524          CALL Agrif_Bc_variable(unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
    525          CALL Agrif_Bc_variable(vnb_id ,calledweight=0._wp, procname=interpvnb)          
     717         CALL wrk_alloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
     718         zuab(:,:) = 0._wp ; zvab(:,:) = 0._wp 
     719         zubb(:,:) = 0._wp ; zvbb(:,:) = 0._wp 
     720         zutn(:,:) = 0._wp ; zvtn(:,:) = 0._wp 
     721         CALL Agrif_Bc_variable(zubb,unb_id ,calledweight=0._wp, procname=interpunb) ! Before 
     722         CALL Agrif_Bc_variable(zvbb,vnb_id ,calledweight=0._wp, procname=interpvnb) 
     723         CALL Agrif_Bc_variable(zuab,unb_id ,calledweight=1._wp, procname=interpunb) ! After 
     724         CALL Agrif_Bc_variable(zvab,vnb_id ,calledweight=1._wp, procname=interpvnb) 
     725         CALL Agrif_Bc_variable(zutn,ub2b_id,calledweight=1._wp, procname=interpub2b)! Time integrated 
     726         CALL Agrif_Bc_variable(zvtn,vb2b_id,calledweight=1._wp, procname=interpvb2b) 
     727          
     728         ! Time indexes bounds for integration 
     729         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
     730         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
     731 
     732         ! Polynomial interpolation coefficients: 
     733         zaa = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
     734                 &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
     735         zab = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
     736                 &      - zt0        * (       zt0 - 1._wp)**2._wp ) 
     737         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
     738                 &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
     739 
     740         ! Do time interpolation 
     741         IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     742            DO jj=1,jpj 
     743               zunb(2,jj) = zaa * zuab(2,jj) + zab * zubb(2,jj) + zat * zutn(2,jj) 
     744               zvnb(2,jj) = zaa * zvab(2,jj) + zab * zvbb(2,jj) + zat * zvtn(2,jj) 
     745            END DO 
     746         ENDIF 
     747         IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     748            DO jj=1,jpj 
     749               zunb(nlci-2,jj) = zaa * zuab(nlci-2,jj) + zab * zubb(nlci-2,jj) + zat * zutn(nlci-2,jj) 
     750               zvnb(nlci-1,jj) = zaa * zvab(nlci-1,jj) + zab * zvbb(nlci-1,jj) + zat * zvtn(nlci-1,jj) 
     751            END DO 
     752         ENDIF 
     753         IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     754            DO ji=1,jpi 
     755               zunb(ji,2) = zaa * zuab(ji,2) + zab * zubb(ji,2) + zat * zutn(ji,2) 
     756               zvnb(ji,2) = zaa * zvab(ji,2) + zab * zvbb(ji,2) + zat * zvtn(ji,2) 
     757            END DO 
     758         ENDIF 
     759         IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     760            DO ji=1,jpi 
     761               zunb(ji,nlcj-1) = zaa * zuab(ji,nlcj-1) + zab * zubb(ji,nlcj-1) + zat * zutn(ji,nlcj-1) 
     762               zvnb(ji,nlcj-2) = zaa * zvab(ji,nlcj-2) + zab * zvbb(ji,nlcj-2) + zat * zvtn(ji,nlcj-2) 
     763            END DO 
     764         ENDIF 
     765         CALL wrk_dealloc( jpi, jpj, zuab, zvab, zubb, zvbb, zutn, zvtn ) 
     766 
    526767      ELSE ! Linear interpolation 
    527          bdy_tinterp = 0 
    528          ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0  
    529          ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0  
    530          ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0  
    531          ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0  
    532          CALL Agrif_Bc_variable(unb_id,calledweight=zt, procname=interpunb) 
    533          CALL Agrif_Bc_variable(vnb_id,calledweight=zt, procname=interpvnb) 
     768         zunb(:,:) = 0._wp ; zvnb(:,:) = 0._wp 
     769         CALL Agrif_Bc_variable(zunb,unb_id,calledweight=zt, procname=interpunb) 
     770         CALL Agrif_Bc_variable(zvnb,vnb_id,calledweight=zt, procname=interpvnb) 
    534771      ENDIF 
    535772      Agrif_UseSpecialValue = .FALSE. 
    536       !  
     773 
     774      ! Fill boundary data arrays: 
     775      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
     776         DO jj=1,jpj 
     777               ubdy_w(jj) = (zunb(2,jj)/(zrhoy*e2u(2,jj))) * umask(2,jj,1) 
     778               vbdy_w(jj) = (zvnb(2,jj)/(zrhox*e1v(2,jj))) * vmask(2,jj,1) 
     779               hbdy_w(jj) = zsshn(2,jj) * tmask(2,jj,1) 
     780         END DO 
     781      ENDIF 
     782 
     783      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
     784         DO jj=1,jpj 
     785               ubdy_e(jj) = zunb(nlci-2,jj)/(zrhoy*e2u(nlci-2,jj)) * umask(nlci-2,jj,1) 
     786               vbdy_e(jj) = zvnb(nlci-1,jj)/(zrhox*e1v(nlci-1,jj)) * vmask(nlci-1,jj,1) 
     787               hbdy_e(jj) = zsshn(nlci-1,jj) * tmask(nlci-1,jj,1) 
     788         END DO 
     789      ENDIF 
     790 
     791      IF((nbondj == -1).OR.(nbondj == 2)) THEN 
     792         DO ji=1,jpi 
     793               ubdy_s(ji) = zunb(ji,2)/(zrhoy*e2u(ji,2)) * umask(ji,2,1) 
     794               vbdy_s(ji) = zvnb(ji,2)/(zrhox*e1v(ji,2)) * vmask(ji,2,1) 
     795               hbdy_s(ji) = zsshn(ji,2) * tmask(ji,2,1) 
     796         END DO 
     797      ENDIF 
     798 
     799      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
     800         DO ji=1,jpi 
     801            ubdy_n(ji) = zunb(ji,nlcj-1)/(zrhoy*e2u(ji,nlcj-1)) * umask(ji,nlcj-1,1) 
     802            vbdy_n(ji) = zvnb(ji,nlcj-2)/(zrhox*e1v(ji,nlcj-2)) * vmask(ji,nlcj-2,1) 
     803            hbdy_n(ji) = zsshn(ji,nlcj-1) * tmask(ji,nlcj-1,1) 
     804         END DO 
     805      ENDIF 
     806 
     807      CALL wrk_dealloc( jpi, jpj, zunb, zvnb, zsshn ) 
     808 
    537809   END SUBROUTINE Agrif_dta_ts 
    538810 
    … …  
    546818 
    547819      IF( Agrif_Root() )   RETURN 
     820 
    548821 
    549822      IF((nbondi == -1).OR.(nbondi == 2)) THEN 
    … …  
    554827      IF((nbondi == 1).OR.(nbondi == 2)) THEN 
    555828         ssha(nlci-1,:)=ssha(nlci-2,:) 
    556          sshn(nlci-1,:)=sshn(nlci-2,:) 
     829         sshn(nlci-1,:)=sshn(nlci-2,:)         
    557830      ENDIF 
    558831 
    … …  
    564837      IF((nbondj == 1).OR.(nbondj == 2)) THEN 
    565838         ssha(:,nlcj-1)=ssha(:,nlcj-2) 
    566          sshn(:,nlcj-1)=sshn(:,nlcj-2) 
     839         sshn(:,nlcj-1)=sshn(:,nlcj-2)                 
    567840      ENDIF 
    568841 
    … …  
    604877   END SUBROUTINE Agrif_ssh_ts 
    605878 
    606 # if defined key_zdftke 
    607    SUBROUTINE Agrif_tke 
    608       !!---------------------------------------------------------------------- 
    609       !!                  ***  ROUTINE Agrif_tke  *** 
    610       !!----------------------------------------------------------------------   
    611       REAL(wp) ::   zalpha 
    612       ! 
    613       zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp ) 
    614       IF( zalpha > 1. )   zalpha = 1. 
    615        
    616       Agrif_SpecialValue    = 0.e0 
    617       Agrif_UseSpecialValue = .TRUE. 
    618        
    619       CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)        
    620                
    621       Agrif_UseSpecialValue = .FALSE. 
    622       ! 
    623    END SUBROUTINE Agrif_tke 
    624 # endif 
    625  
    626    SUBROUTINE interptsn(ptab,i1,i2,j1,j2,k1,k2,n1,n2,before,nb,ndir) 
    627       !!--------------------------------------------- 
    628       !!   *** ROUTINE interptsn *** 
    629       !!--------------------------------------------- 
    630       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
    631       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    632       LOGICAL, INTENT(in) :: before 
    633       INTEGER, INTENT(in) :: nb , ndir 
    634       ! 
    635       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    636       INTEGER :: imin, imax, jmin, jmax 
    637       REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3 
    638       REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7 
    639       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    640  
    641       IF (before) THEN          
    642          ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2) 
    643       ELSE 
    644          ! 
    645          western_side  = (nb == 1).AND.(ndir == 1) 
    646          eastern_side  = (nb == 1).AND.(ndir == 2) 
    647          southern_side = (nb == 2).AND.(ndir == 1) 
    648          northern_side = (nb == 2).AND.(ndir == 2) 
    649          ! 
    650          zrhox = Agrif_Rhox() 
    651          !  
    652          zalpha1 = ( zrhox - 1. ) * 0.5 
    653          zalpha2 = 1. - zalpha1 
    654          !  
    655          zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. ) 
    656          zalpha4 = 1. - zalpha3 
    657          !  
    658          zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. ) 
    659          zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. ) 
    660          zalpha5 = 1. - zalpha6 - zalpha7 
    661          ! 
    662          imin = i1 
    663          imax = i2 
    664          jmin = j1 
    665          jmax = j2 
    666          !  
    667          ! Remove CORNERS 
    668          IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3 
    669          IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2 
    670          IF((nbondi == -1).OR.(nbondi == 2)) imin = 3 
    671          IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2         
    672          ! 
    673          IF( eastern_side) THEN 
    674             DO jn = 1, jpts 
    675                tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn) 
    676                DO jk = 1, jpkm1 
    677                   DO jj = jmin,jmax 
    678                      IF( umask(nlci-2,jj,jk) == 0.e0 ) THEN 
    679                         tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk) 
    680                      ELSE 
    681                         tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk) 
    682                         IF( un(nlci-2,jj,jk) > 0.e0 ) THEN 
    683                            tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) &  
    684                                  + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk) 
    685                         ENDIF 
    686                      ENDIF 
    687                   END DO 
    688                END DO 
    689             ENDDO 
    690          ENDIF 
    691          !  
    692          IF( northern_side ) THEN             
    693             DO jn = 1, jpts 
    694                tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn) 
    695                DO jk = 1, jpkm1 
    696                   DO ji = imin,imax 
    697                      IF( vmask(ji,nlcj-2,jk) == 0.e0 ) THEN 
    698                         tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk) 
    699                      ELSE 
    700                         tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)         
    701                         IF (vn(ji,nlcj-2,jk) > 0.e0 ) THEN 
    702                            tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  & 
    703                                  + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk) 
    704                         ENDIF 
    705                      ENDIF 
    706                   END DO 
    707                END DO 
    708             ENDDO 
    709          ENDIF 
    710          ! 
    711          IF( western_side) THEN             
    712             DO jn = 1, jpts 
    713                tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn) 
    714                DO jk = 1, jpkm1 
    715                   DO jj = jmin,jmax 
    716                      IF( umask(2,jj,jk) == 0.e0 ) THEN 
    717                         tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk) 
    718                      ELSE 
    719                         tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)         
    720                         IF( un(2,jj,jk) < 0.e0 ) THEN 
    721                            tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk) 
    722                         ENDIF 
    723                      ENDIF 
    724                   END DO 
    725                END DO 
    726             END DO 
    727          ENDIF 
    728          ! 
    729          IF( southern_side ) THEN            
    730             DO jn = 1, jpts 
    731                tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn) 
    732                DO jk=1,jpk       
    733                   DO ji=imin,imax 
    734                      IF( vmask(ji,2,jk) == 0.e0 ) THEN 
    735                         tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk) 
    736                      ELSE 
    737                         tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk) 
    738                         IF( vn(ji,2,jk) < 0.e0 ) THEN 
    739                            tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk) 
    740                         ENDIF 
    741                      ENDIF 
    742                   END DO 
    743                END DO 
    744             ENDDO 
    745          ENDIF 
    746          ! 
    747          ! Treatment of corners 
    748          !  
    749          ! East south 
    750          IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    751             tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:) 
    752          ENDIF 
    753          ! East north 
    754          IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    755             tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:) 
    756          ENDIF 
    757          ! West south 
    758          IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN 
    759             tsa(2,2,:,:) = ptab(2,2,:,:) 
    760          ENDIF 
    761          ! West north 
    762          IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN 
    763             tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:) 
    764          ENDIF 
    765          ! 
    766       ENDIF 
    767       ! 
    768    END SUBROUTINE interptsn 
    769  
    770    SUBROUTINE interpsshn(ptab,i1,i2,j1,j2,before,nb,ndir) 
     879   SUBROUTINE interpsshn(tabres,i1,i2,j1,j2) 
    771880      !!---------------------------------------------------------------------- 
    772881      !!                  ***  ROUTINE interpsshn  *** 
    773882      !!----------------------------------------------------------------------   
    774883      INTEGER, INTENT(in) :: i1,i2,j1,j2 
    775       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    776       LOGICAL, INTENT(in) :: before 
    777       INTEGER, INTENT(in) :: nb , ndir 
    778       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    779       !!----------------------------------------------------------------------   
    780       ! 
    781       IF( before) THEN 
    782          ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
    783       ELSE 
    784          western_side  = (nb == 1).AND.(ndir == 1) 
    785          eastern_side  = (nb == 1).AND.(ndir == 2) 
    786          southern_side = (nb == 2).AND.(ndir == 1) 
    787          northern_side = (nb == 2).AND.(ndir == 2) 
    788          IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
    789          IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1) 
    790          IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
    791          IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1) 
    792       ENDIF 
    793       ! 
     884      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     885      !! 
     886      INTEGER :: ji,jj 
     887      !!----------------------------------------------------------------------   
     888 
     889      tabres(i1:i2,j1:j2) = sshn(i1:i2,j1:j2) 
     890 
    794891   END SUBROUTINE interpsshn 
    795892 
    796    SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2, before) 
    797       !!--------------------------------------------- 
    798       !!   *** ROUTINE interpun *** 
    799       !!---------------------------------------------     
    800       !! 
     893   SUBROUTINE interpu(tabres,i1,i2,j1,j2,k1,k2) 
     894      !!---------------------------------------------------------------------- 
     895      !!                  ***  ROUTINE interpu  *** 
     896      !!----------------------------------------------------------------------   
    801897      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    802       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    803       LOGICAL, INTENT(in) :: before 
     898      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    804899      !! 
    805900      INTEGER :: ji,jj,jk 
    806       REAL(wp) :: zrhoy  
    807       !!---------------------------------------------     
    808       ! 
    809       IF (before) THEN  
    810          DO jk=1,jpk 
    811             DO jj=j1,j2 
    812                DO ji=i1,i2 
    813                   ptab(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
    814                   ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3u(ji,jj,jk) 
    815                END DO 
    816             END DO 
    817          END DO 
    818       ELSE 
    819          zrhoy = Agrif_Rhoy() 
    820          DO jk=1,jpkm1 
    821             DO jj=j1,j2 
    822                ua(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj))) 
    823                ua(i1:i2,jj,jk) = ua(i1:i2,jj,jk) / fse3u(i1:i2,jj,jk) 
    824             END DO 
    825          END DO 
    826       ENDIF 
    827       !  
    828    END SUBROUTINE interpun 
    829  
    830  
    831    SUBROUTINE interpun2d(ptab,i1,i2,j1,j2,before) 
    832       !!--------------------------------------------- 
    833       !!   *** ROUTINE interpun *** 
    834       !!---------------------------------------------     
    835       ! 
    836       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    837       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    838       LOGICAL, INTENT(in) :: before 
    839       ! 
    840       INTEGER :: ji,jj 
    841       REAL(wp) :: ztref 
    842       REAL(wp) :: zrhoy  
    843       !!---------------------------------------------     
    844       ! 
    845       ztref = 1. 
    846  
    847       IF (before) THEN  
    848          DO jj=j1,j2 
    849             DO ji=i1,MIN(i2,nlci-1) 
    850                ptab(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj))  
    851             END DO 
    852          END DO 
    853       ELSE 
    854          zrhoy = Agrif_Rhoy() 
    855          DO jj=j1,j2 
    856             laplacu(i1:i2,jj) = ztref * (ptab(i1:i2,jj)/(zrhoy*e2u(i1:i2,jj))) !*umask(i1:i2,jj,1) 
    857          END DO 
    858       ENDIF 
    859       !  
    860    END SUBROUTINE interpun2d 
    861  
    862  
    863    SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2, before) 
    864       !!--------------------------------------------- 
    865       !!   *** ROUTINE interpvn *** 
    866       !!---------------------------------------------     
    867       ! 
    868       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    869       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    870       LOGICAL, INTENT(in) :: before 
    871       ! 
    872       INTEGER :: ji,jj,jk 
    873       REAL(wp) :: zrhox  
    874       !!---------------------------------------------     
    875       !       
    876       IF (before) THEN           
    877          !interpv entre 1 et k2 et interpv2d en jpkp1 
    878          DO jk=k1,jpk 
    879             DO jj=j1,j2 
    880                DO ji=i1,i2 
    881                   ptab(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
    882                   ptab(ji,jj,jk) = ptab(ji,jj,jk) * fse3v(ji,jj,jk) 
    883                END DO 
    884             END DO 
    885          END DO 
    886       ELSE           
    887          zrhox= Agrif_Rhox() 
    888          DO jk=1,jpkm1 
    889             DO jj=j1,j2 
    890                va(i1:i2,jj,jk) = (ptab(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj))) 
    891                va(i1:i2,jj,jk) = va(i1:i2,jj,jk) / fse3v(i1:i2,jj,jk) 
    892             END DO 
    893          END DO 
    894       ENDIF 
    895       !         
    896    END SUBROUTINE interpvn 
    897  
    898    SUBROUTINE interpvn2d(ptab,i1,i2,j1,j2,before) 
    899       !!--------------------------------------------- 
    900       !!   *** ROUTINE interpvn *** 
    901       !!---------------------------------------------     
    902       ! 
    903       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    904       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    905       LOGICAL, INTENT(in) :: before 
    906       ! 
    907       INTEGER :: ji,jj 
    908       REAL(wp) :: zrhox  
    909       REAL(wp) :: ztref 
    910       !!---------------------------------------------     
    911       !  
    912       ztref = 1.     
    913       IF (before) THEN  
    914          !interpv entre 1 et k2 et interpv2d en jpkp1 
    915          DO jj=j1,MIN(j2,nlcj-1) 
    916             DO ji=i1,i2 
    917                ptab(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) * vmask(ji,jj,1) 
    918             END DO 
    919          END DO 
    920       ELSE            
    921          zrhox = Agrif_Rhox() 
    922          DO ji=i1,i2 
    923             laplacv(ji,j1:j2) = ztref * (ptab(ji,j1:j2)/(zrhox*e1v(ji,j1:j2))) 
    924          END DO 
    925       ENDIF 
    926       !       
    927    END SUBROUTINE interpvn2d 
    928  
    929    SUBROUTINE interpunb(ptab,i1,i2,j1,j2,before,nb,ndir) 
    930       !!---------------------------------------------------------------------- 
    931       !!                  ***  ROUTINE interpunb  *** 
    932       !!----------------------------------------------------------------------   
    933       INTEGER, INTENT(in) :: i1,i2,j1,j2 
    934       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    935       LOGICAL, INTENT(in) :: before 
    936       INTEGER, INTENT(in) :: nb , ndir 
    937       !! 
    938       INTEGER :: ji,jj 
    939       REAL(wp) :: zrhoy, zrhot, zt0, zt1, ztcoeff 
    940       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    941       !!----------------------------------------------------------------------   
    942       ! 
    943       IF (before) THEN  
     901      !!----------------------------------------------------------------------   
     902 
     903      DO jk=k1,k2 
    944904         DO jj=j1,j2 
    945905            DO ji=i1,i2 
    946                ptab(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
    947             END DO 
    948          END DO 
    949       ELSE 
    950          western_side  = (nb == 1).AND.(ndir == 1) 
    951          eastern_side  = (nb == 1).AND.(ndir == 2) 
    952          southern_side = (nb == 2).AND.(ndir == 1) 
    953          northern_side = (nb == 2).AND.(ndir == 2) 
    954          zrhoy = Agrif_Rhoy() 
    955          zrhot = Agrif_rhot() 
    956          ! Time indexes bounds for integration 
    957          zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    958          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
    959          ! Polynomial interpolation coefficients: 
    960          IF( bdy_tinterp == 1 ) THEN 
    961             ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    962                   &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    963          ELSEIF( bdy_tinterp == 2 ) THEN 
    964             ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    965                   &      - zt0        * (       zt0 - 1._wp)**2._wp )  
    966  
    967          ELSE 
    968             ztcoeff = 1 
    969          ENDIF 
    970          !    
    971          IF(western_side) THEN 
    972             ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    973          ENDIF 
    974          IF(eastern_side) THEN 
    975             ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    976          ENDIF 
    977          IF(southern_side) THEN 
    978             ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    979          ENDIF 
    980          IF(northern_side) THEN 
    981             ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    982          ENDIF 
    983          !             
    984          IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    985             IF(western_side) THEN 
    986                ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
    987                      &                                  * umask(i1,j1:j2,1) 
    988             ENDIF 
    989             IF(eastern_side) THEN 
    990                ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2))   & 
    991                      &                                  * umask(i1,j1:j2,1) 
    992             ENDIF 
    993             IF(southern_side) THEN 
    994                ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
    995                      &                                  * umask(i1:i2,j1,1) 
    996             ENDIF 
    997             IF(northern_side) THEN 
    998                ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1))   & 
    999                      &                                  * umask(i1:i2,j1,1) 
    1000             ENDIF 
    1001          ENDIF 
    1002       ENDIF 
    1003       !  
    1004    END SUBROUTINE interpunb 
    1005  
    1006    SUBROUTINE interpvnb(ptab,i1,i2,j1,j2,before,nb,ndir) 
    1007       !!---------------------------------------------------------------------- 
    1008       !!                  ***  ROUTINE interpvnb  *** 
     906               tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk) 
     907               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk) 
     908            END DO 
     909         END DO 
     910      END DO 
     911   END SUBROUTINE interpu 
     912 
     913 
     914   SUBROUTINE interpu2d(tabres,i1,i2,j1,j2) 
     915      !!---------------------------------------------------------------------- 
     916      !!                  ***  ROUTINE interpu2d  *** 
    1009917      !!----------------------------------------------------------------------   
    1010918      INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1011       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    1012       LOGICAL, INTENT(in) :: before 
    1013       INTEGER, INTENT(in) :: nb , ndir 
     919      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    1014920      !! 
    1015921      INTEGER :: ji,jj 
    1016       REAL(wp) :: zrhox, zrhot, zt0, zt1, ztcoeff    
    1017       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    1018       !!----------------------------------------------------------------------   
    1019       !  
    1020       IF (before) THEN  
     922      !!----------------------------------------------------------------------   
     923 
     924      DO jj=j1,j2 
     925         DO ji=i1,i2 
     926            tabres(ji,jj) = e2u(ji,jj) * ((gcx(ji+1,jj) - gcx(ji,jj))/e1u(ji,jj)) & 
     927               * umask(ji,jj,1) 
     928         END DO 
     929      END DO 
     930 
     931   END SUBROUTINE interpu2d 
     932 
     933 
     934   SUBROUTINE interpv(tabres,i1,i2,j1,j2,k1,k2) 
     935      !!---------------------------------------------------------------------- 
     936      !!                  ***  ROUTINE interpv  *** 
     937      !!----------------------------------------------------------------------   
     938      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
     939      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
     940      !! 
     941      INTEGER :: ji, jj, jk 
     942      !!----------------------------------------------------------------------   
     943 
     944      DO jk=k1,k2 
    1021945         DO jj=j1,j2 
    1022946            DO ji=i1,i2 
    1023                ptab(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj)  
    1024             END DO 
    1025          END DO 
    1026       ELSE 
    1027          western_side  = (nb == 1).AND.(ndir == 1) 
    1028          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1029          southern_side = (nb == 2).AND.(ndir == 1) 
    1030          northern_side = (nb == 2).AND.(ndir == 2) 
    1031          zrhox = Agrif_Rhox() 
    1032          zrhot = Agrif_rhot() 
    1033          ! Time indexes bounds for integration 
    1034          zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1035          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot       
    1036          IF( bdy_tinterp == 1 ) THEN 
    1037             ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        & 
    1038                   &      - zt0**2._wp * (       zt0 - 1._wp)        ) 
    1039          ELSEIF( bdy_tinterp == 2 ) THEN 
    1040             ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp & 
    1041                   &      - zt0        * (       zt0 - 1._wp)**2._wp )  
    1042  
    1043          ELSE 
    1044             ztcoeff = 1 
    1045          ENDIF 
    1046          ! 
    1047          IF(western_side) THEN 
    1048             vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    1049          ENDIF 
    1050          IF(eastern_side) THEN 
    1051             vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2)   
    1052          ENDIF 
    1053          IF(southern_side) THEN 
    1054             vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
    1055          ENDIF 
    1056          IF(northern_side) THEN 
    1057             vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1)  
    1058          ENDIF 
    1059          !             
    1060          IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN 
    1061             IF(western_side) THEN 
    1062                vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    1063                      &                                  * vmask(i1,j1:j2,1) 
    1064             ENDIF 
    1065             IF(eastern_side) THEN 
    1066                vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   & 
    1067                      &                                  * vmask(i1,j1:j2,1) 
    1068             ENDIF 
    1069             IF(southern_side) THEN 
    1070                vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    1071                      &                                  * vmask(i1:i2,j1,1) 
    1072             ENDIF 
    1073             IF(northern_side) THEN 
    1074                vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   & 
    1075                      &                                  * vmask(i1:i2,j1,1) 
    1076             ENDIF 
    1077          ENDIF 
    1078       ENDIF 
    1079       ! 
     947               tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk) 
     948               tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk) 
     949            END DO 
     950         END DO 
     951      END DO 
     952 
     953   END SUBROUTINE interpv 
     954 
     955 
     956   SUBROUTINE interpv2d(tabres,i1,i2,j1,j2) 
     957      !!---------------------------------------------------------------------- 
     958      !!                  ***  ROUTINE interpu2d  *** 
     959      !!----------------------------------------------------------------------   
     960      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     961      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     962      !! 
     963      INTEGER :: ji,jj 
     964      !!----------------------------------------------------------------------   
     965 
     966      DO jj=j1,j2 
     967         DO ji=i1,i2 
     968            tabres(ji,jj) = e1v(ji,jj) * ((gcx(ji,jj+1) - gcx(ji,jj))/e2v(ji,jj)) & 
     969               * vmask(ji,jj,1) 
     970         END DO 
     971      END DO 
     972 
     973   END SUBROUTINE interpv2d 
     974 
     975   SUBROUTINE interpunb(tabres,i1,i2,j1,j2) 
     976      !!---------------------------------------------------------------------- 
     977      !!                  ***  ROUTINE interpunb  *** 
     978      !!----------------------------------------------------------------------   
     979      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     980      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     981      !! 
     982      INTEGER :: ji,jj 
     983      !!----------------------------------------------------------------------   
     984 
     985      DO jj=j1,j2 
     986         DO ji=i1,i2 
     987            tabres(ji,jj) = un_b(ji,jj) * e2u(ji,jj) * hu(ji,jj)  
     988         END DO 
     989      END DO 
     990 
     991   END SUBROUTINE interpunb 
     992 
     993   SUBROUTINE interpvnb(tabres,i1,i2,j1,j2) 
     994      !!---------------------------------------------------------------------- 
     995      !!                  ***  ROUTINE interpvnb  *** 
     996      !!----------------------------------------------------------------------   
     997      INTEGER, INTENT(in) :: i1,i2,j1,j2 
     998      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
     999      !! 
     1000      INTEGER :: ji,jj 
     1001      !!----------------------------------------------------------------------   
     1002 
     1003      DO jj=j1,j2 
     1004         DO ji=i1,i2 
     1005            tabres(ji,jj) = vn_b(ji,jj) * e1v(ji,jj) * hv(ji,jj) 
     1006         END DO 
     1007      END DO 
     1008 
    10801009   END SUBROUTINE interpvnb 
    10811010 
    1082    SUBROUTINE interpub2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1011   SUBROUTINE interpub2b(tabres,i1,i2,j1,j2) 
    10831012      !!---------------------------------------------------------------------- 
    10841013      !!                  ***  ROUTINE interpub2b  *** 
    10851014      !!----------------------------------------------------------------------   
    10861015      INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1087       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    1088       LOGICAL, INTENT(in) :: before 
    1089       INTEGER, INTENT(in) :: nb , ndir 
     1016      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    10901017      !! 
    10911018      INTEGER :: ji,jj 
    1092       REAL(wp) :: zrhot, zt0, zt1,zat 
    1093       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    1094       !!----------------------------------------------------------------------   
    1095       IF( before ) THEN 
    1096          DO jj=j1,j2 
    1097             DO ji=i1,i2 
    1098                ptab(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
    1099             END DO 
    1100          END DO 
    1101       ELSE 
    1102          western_side  = (nb == 1).AND.(ndir == 1) 
    1103          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1104          southern_side = (nb == 2).AND.(ndir == 1) 
    1105          northern_side = (nb == 2).AND.(ndir == 2) 
    1106          zrhot = Agrif_rhot() 
    1107          ! Time indexes bounds for integration 
    1108          zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1109          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    1110          ! Polynomial interpolation coefficients: 
    1111          zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    1112                &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    1113          !  
    1114          IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
    1115          IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
    1116          IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
    1117          IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
    1118       ENDIF 
    1119       !  
     1019      !!----------------------------------------------------------------------   
     1020 
     1021      DO jj=j1,j2 
     1022         DO ji=i1,i2 
     1023            tabres(ji,jj) = ub2_b(ji,jj) * e2u(ji,jj) 
     1024         END DO 
     1025      END DO 
     1026 
    11201027   END SUBROUTINE interpub2b 
    11211028 
    1122    SUBROUTINE interpvb2b(ptab,i1,i2,j1,j2,before,nb,ndir) 
     1029   SUBROUTINE interpvb2b(tabres,i1,i2,j1,j2) 
    11231030      !!---------------------------------------------------------------------- 
    11241031      !!                  ***  ROUTINE interpvb2b  *** 
    11251032      !!----------------------------------------------------------------------   
    11261033      INTEGER, INTENT(in) :: i1,i2,j1,j2 
    1127       REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: ptab 
    1128       LOGICAL, INTENT(in) :: before 
    1129       INTEGER, INTENT(in) :: nb , ndir 
     1034      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    11301035      !! 
    11311036      INTEGER :: ji,jj 
    1132       REAL(wp) :: zrhot, zt0, zt1,zat 
    1133       LOGICAL :: western_side, eastern_side,northern_side,southern_side 
    1134       !!----------------------------------------------------------------------   
    1135       ! 
    1136       IF( before ) THEN 
    1137          DO jj=j1,j2 
    1138             DO ji=i1,i2 
    1139                ptab(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
    1140             END DO 
    1141          END DO 
    1142       ELSE       
    1143          western_side  = (nb == 1).AND.(ndir == 1) 
    1144          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1145          southern_side = (nb == 2).AND.(ndir == 1) 
    1146          northern_side = (nb == 2).AND.(ndir == 2) 
    1147          zrhot = Agrif_rhot() 
    1148          ! Time indexes bounds for integration 
    1149          zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot 
    1150          zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot 
    1151          ! Polynomial interpolation coefficients: 
    1152          zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)        & 
    1153                &      - zt0**2._wp * (-2._wp*zt0 + 3._wp)        )  
    1154          ! 
    1155          IF(western_side ) vbdy_w(j1:j2) = zat * ptab(i1,j1:j2)   
    1156          IF(eastern_side ) vbdy_e(j1:j2) = zat * ptab(i1,j1:j2)   
    1157          IF(southern_side) vbdy_s(i1:i2) = zat * ptab(i1:i2,j1)  
    1158          IF(northern_side) vbdy_n(i1:i2) = zat * ptab(i1:i2,j1)  
    1159       ENDIF 
    1160       !       
     1037      !!----------------------------------------------------------------------   
     1038 
     1039      DO jj=j1,j2 
     1040         DO ji=i1,i2 
     1041            tabres(ji,jj) = vb2_b(ji,jj) * e1v(ji,jj) 
     1042         END DO 
     1043      END DO 
     1044 
    11611045   END SUBROUTINE interpvb2b 
    1162  
    1163    SUBROUTINE interpe3t(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
    1164       !!---------------------------------------------------------------------- 
    1165       !!                  ***  ROUTINE interpe3t  *** 
    1166       !!----------------------------------------------------------------------   
    1167       !  
    1168       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    1169       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    1170       LOGICAL :: before 
    1171       INTEGER, INTENT(in) :: nb , ndir 
    1172       ! 
    1173       INTEGER :: ji, jj, jk 
    1174       LOGICAL :: western_side, eastern_side, northern_side, southern_side 
    1175       REAL(wp) :: ztmpmsk       
    1176       !!----------------------------------------------------------------------   
    1177       !     
    1178       IF (before) THEN 
    1179          DO jk=k1,k2 
    1180             DO jj=j1,j2 
    1181                DO ji=i1,i2 
    1182                   ptab(ji,jj,jk) = tmask(ji,jj,jk) * e3t_0(ji,jj,jk) 
    1183                END DO 
    1184             END DO 
    1185          END DO 
    1186       ELSE 
    1187          western_side  = (nb == 1).AND.(ndir == 1) 
    1188          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1189          southern_side = (nb == 2).AND.(ndir == 1) 
    1190          northern_side = (nb == 2).AND.(ndir == 2) 
    1191  
    1192          DO jk=k1,k2 
    1193             DO jj=j1,j2 
    1194                DO ji=i1,i2 
    1195                   ! Get velocity mask at boundary edge points: 
    1196                   IF (western_side)  ztmpmsk = umask(ji    ,jj    ,1) 
    1197                   IF (eastern_side)  ztmpmsk = umask(nlci-2,jj    ,1) 
    1198                   IF (northern_side) ztmpmsk = vmask(ji    ,nlcj-2,1) 
    1199                   IF (southern_side) ztmpmsk = vmask(ji    ,2     ,1) 
    1200  
    1201                   IF (ABS(ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk))*ztmpmsk > 1.D-2) THEN 
    1202                      IF (western_side) THEN 
    1203                         WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1204                      ELSEIF (eastern_side) THEN 
    1205                         WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1206                      ELSEIF (southern_side) THEN 
    1207                         WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
    1208                      ELSEIF (northern_side) THEN 
    1209                         WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk 
    1210                      ENDIF 
    1211                      WRITE(numout,*) '      ptab(ji,jj,jk), fse3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk) 
    1212                      kindic_agr = kindic_agr + 1 
    1213                   ENDIF 
    1214                END DO 
    1215             END DO 
    1216          END DO 
    1217  
    1218       ENDIF 
    1219       !  
    1220    END SUBROUTINE interpe3t 
    1221  
    1222    SUBROUTINE interpumsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
    1223       !!---------------------------------------------------------------------- 
    1224       !!                  ***  ROUTINE interpumsk  *** 
    1225       !!----------------------------------------------------------------------   
    1226       !  
    1227       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    1228       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    1229       LOGICAL :: before 
    1230       INTEGER, INTENT(in) :: nb , ndir 
    1231       ! 
    1232       INTEGER :: ji, jj, jk 
    1233       LOGICAL :: western_side, eastern_side    
    1234       !!----------------------------------------------------------------------   
    1235       !     
    1236       IF (before) THEN 
    1237          DO jk=k1,k2 
    1238             DO jj=j1,j2 
    1239                DO ji=i1,i2 
    1240                   ptab(ji,jj,jk) = umask(ji,jj,jk) 
    1241                END DO 
    1242             END DO 
    1243          END DO 
    1244       ELSE 
    1245  
    1246          western_side  = (nb == 1).AND.(ndir == 1) 
    1247          eastern_side  = (nb == 1).AND.(ndir == 2) 
    1248          DO jk=k1,k2 
    1249             DO jj=j1,j2 
    1250                DO ji=i1,i2 
    1251                    ! Velocity mask at boundary edge points: 
    1252                   IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN 
    1253                      IF (western_side) THEN 
    1254                         WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1255                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
    1256                         kindic_agr = kindic_agr + 1 
    1257                      ELSEIF (eastern_side) THEN 
    1258                         WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1259                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk) 
    1260                         kindic_agr = kindic_agr + 1 
    1261                      ENDIF 
    1262                   ENDIF 
    1263                END DO 
    1264             END DO 
    1265          END DO 
    1266  
    1267       ENDIF 
    1268       !  
    1269    END SUBROUTINE interpumsk 
    1270  
    1271    SUBROUTINE interpvmsk(ptab,i1,i2,j1,j2,k1,k2,before,nb,ndir) 
    1272       !!---------------------------------------------------------------------- 
    1273       !!                  ***  ROUTINE interpvmsk  *** 
    1274       !!----------------------------------------------------------------------   
    1275       !  
    1276       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    1277       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    1278       LOGICAL :: before 
    1279       INTEGER, INTENT(in) :: nb , ndir 
    1280       ! 
    1281       INTEGER :: ji, jj, jk 
    1282       LOGICAL :: northern_side, southern_side      
    1283       !!----------------------------------------------------------------------   
    1284       !     
    1285       IF (before) THEN 
    1286          DO jk=k1,k2 
    1287             DO jj=j1,j2 
    1288                DO ji=i1,i2 
    1289                   ptab(ji,jj,jk) = vmask(ji,jj,jk) 
    1290                END DO 
    1291             END DO 
    1292          END DO 
    1293       ELSE 
    1294  
    1295          southern_side = (nb == 2).AND.(ndir == 1) 
    1296          northern_side = (nb == 2).AND.(ndir == 2) 
    1297          DO jk=k1,k2 
    1298             DO jj=j1,j2 
    1299                DO ji=i1,i2 
    1300                    ! Velocity mask at boundary edge points: 
    1301                   IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN 
    1302                      IF (southern_side) THEN 
    1303                         WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1304                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
    1305                         kindic_agr = kindic_agr + 1 
    1306                      ELSEIF (northern_side) THEN 
    1307                         WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk 
    1308                         WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk) 
    1309                         kindic_agr = kindic_agr + 1 
    1310                      ENDIF 
    1311                   ENDIF 
    1312                END DO 
    1313             END DO 
    1314          END DO 
    1315  
    1316       ENDIF 
    1317       !  
    1318    END SUBROUTINE interpvmsk 
    1319  
    1320 # if defined key_zdftke 
    1321  
    1322    SUBROUTINE interpavm(ptab,i1,i2,j1,j2,k1,k2,before) 
    1323       !!---------------------------------------------------------------------- 
    1324       !!                  ***  ROUTINE interavm  *** 
    1325       !!----------------------------------------------------------------------   
    1326       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2 
    1327       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    1328       LOGICAL, INTENT(in) :: before 
    1329       !!----------------------------------------------------------------------   
    1330       !       
    1331       IF( before) THEN 
    1332          ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
    1333       ELSE 
    1334          avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
    1335       ENDIF 
    1336       ! 
    1337    END SUBROUTINE interpavm 
    1338  
    1339 # endif /* key_zdftke */ 
    13401046 
    13411047#else 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_opa_sponge.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90

    r6617 r6625  
    1 #define TWO_WAY        /* TWO WAY NESTING */ 
    2 #undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/ 
    3   
     1#define TWO_WAY 
     2 
    43MODULE agrif_opa_update 
    54#if defined key_agrif  && ! defined key_offline 
    … …  
    1211   USE wrk_nemo   
    1312   USE dynspg_oce 
    14    USE zdf_oce        ! vertical physics: ocean variables  
    1513 
    1614   IMPLICIT NONE 
    1715   PRIVATE 
    1816 
    19    PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn,Update_Scales 
    20 # if defined key_zdftke 
    21    PUBLIC Agrif_Update_Tke 
    22 # endif 
     17   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn 
     18 
     19   INTEGER, PUBLIC :: nbcline = 0 
     20 
    2321   !!---------------------------------------------------------------------- 
    24    !! NEMO/NST 3.6 , NEMO Consortium (2010) 
     22   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    2523   !! $Id$ 
    2624   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    2927CONTAINS 
    3028 
    31    RECURSIVE SUBROUTINE Agrif_Update_Tra( ) 
     29   SUBROUTINE Agrif_Update_Tra( kt ) 
    3230      !!--------------------------------------------- 
    3331      !!   *** ROUTINE Agrif_Update_Tra *** 
    3432      !!--------------------------------------------- 
    35       !  
    36       IF (Agrif_Root()) RETURN 
    37       ! 
    38 #if defined TWO_WAY   
    39       IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
     33      !! 
     34      INTEGER, INTENT(in) :: kt 
     35      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab 
     36 
     37 
     38      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     39#if defined TWO_WAY 
     40      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab ) 
    4041 
    4142      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4243      Agrif_SpecialValueFineGrid = 0. 
    43       !  
     44 
    4445      IF (MOD(nbcline,nbclineupdate) == 0) THEN 
    45 # if ! defined DECAL_FEEDBACK 
    46          CALL Agrif_Update_Variable(tsn_id, procname=updateTS) 
    47 # else 
    48          CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS) 
    49 # endif 
    50       ELSE 
    51 # if ! defined DECAL_FEEDBACK 
    52          CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS) 
    53 # else 
    54          CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS) 
    55 # endif 
    56       ENDIF 
    57       ! 
     46         CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS) 
     47      ELSE 
     48         CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS) 
     49      ENDIF 
     50 
    5851      Agrif_UseSpecialValueInUpdate = .FALSE. 
    59       ! 
    60       IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
    61          CALL Agrif_ChildGrid_To_ParentGrid() 
    62          CALL Agrif_Update_Tra() 
    63          CALL Agrif_ParentGrid_To_ChildGrid() 
    64       ENDIF 
    65       ! 
     52 
     53      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab ) 
    6654#endif 
    67       ! 
     55 
    6856   END SUBROUTINE Agrif_Update_Tra 
    6957 
    70    RECURSIVE SUBROUTINE Agrif_Update_Dyn( ) 
     58   SUBROUTINE Agrif_Update_Dyn( kt ) 
    7159      !!--------------------------------------------- 
    7260      !!   *** ROUTINE Agrif_Update_Dyn *** 
    7361      !!--------------------------------------------- 
    74       !  
    75       IF (Agrif_Root()) RETURN 
    76       ! 
     62      !! 
     63      INTEGER, INTENT(in) :: kt 
     64      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d 
     65      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab 
     66 
     67 
     68      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return 
    7769#if defined TWO_WAY 
    78       IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline 
    79  
    80       Agrif_UseSpecialValueInUpdate = .FALSE. 
    81       Agrif_SpecialValueFineGrid = 0. 
    82       !      
     70      CALL wrk_alloc( jpi, jpj,      ztab2d ) 
     71      CALL wrk_alloc( jpi, jpj, jpk, ztab   ) 
     72 
    8373      IF (mod(nbcline,nbclineupdate) == 0) THEN 
    84 # if ! defined DECAL_FEEDBACK 
    85          CALL Agrif_Update_Variable(un_update_id,procname = updateU) 
    86          CALL Agrif_Update_Variable(vn_update_id,procname = updateV) 
    87 # else 
    88          CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU) 
    89          CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV) 
    90 # endif 
    91       ELSE 
    92 # if ! defined DECAL_FEEDBACK 
    93          CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU) 
    94          CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)          
    95 # else 
    96          CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU) 
    97          CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV) 
    98 # endif 
    99       ENDIF 
    100  
    101 # if ! defined DECAL_FEEDBACK 
    102       CALL Agrif_Update_Variable(e1u_id,procname = updateU2d) 
    103       CALL Agrif_Update_Variable(e2v_id,procname = updateV2d)   
    104 # else 
    105       CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d) 
    106       CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d)   
    107 # endif 
    108  
    109 # if defined key_dynspg_ts 
     74         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU) 
     75         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV) 
     76      ELSE 
     77         CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU) 
     78         CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)          
     79      ENDIF 
     80 
     81      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d) 
     82      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
     83 
     84#if defined key_dynspg_ts 
    11085      IF (ln_bt_fw) THEN 
    11186         ! Update time integrated transports 
    11287         IF (mod(nbcline,nbclineupdate) == 0) THEN 
    113 #  if ! defined DECAL_FEEDBACK 
    114             CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b) 
    115             CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b) 
    116 #  else 
    117             CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b) 
    118             CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b) 
    119 #  endif 
     88            CALL Agrif_Update_Variable(ztab2d,ub2b_id,procname = updateub2b) 
     89            CALL Agrif_Update_Variable(ztab2d,vb2b_id,procname = updatevb2b) 
    12090         ELSE 
    121 #  if ! defined DECAL_FEEDBACK 
    122             CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b) 
    123             CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b) 
    124 #  else 
    125             CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b) 
    126             CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b) 
    127 #  endif 
     91            CALL Agrif_Update_Variable(ztab2d,ub2b_id,locupdate=(/0,1/),procname = updateub2b) 
     92            CALL Agrif_Update_Variable(ztab2d,vb2b_id,locupdate=(/0,1/),procname = updatevb2b) 
    12893         ENDIF 
    129       END IF 
    130 # endif 
    131       ! 
     94      END IF  
     95#endif 
     96 
    13297      nbcline = nbcline + 1 
    133       ! 
    134       Agrif_UseSpecialValueInUpdate = .TRUE. 
     98 
     99      Agrif_UseSpecialValueInUpdate = .TRUE.  
    135100      Agrif_SpecialValueFineGrid = 0. 
    136 # if ! defined DECAL_FEEDBACK 
    137       CALL Agrif_Update_Variable(sshn_id,procname = updateSSH) 
    138 # else 
    139       CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH) 
    140 # endif 
     101      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH) 
    141102      Agrif_UseSpecialValueInUpdate = .FALSE. 
    142       !  
     103 
     104      CALL wrk_dealloc( jpi, jpj,      ztab2d ) 
     105      CALL wrk_dealloc( jpi, jpj, jpk, ztab   ) 
     106 
     107!Done in step 
     108!      CALL Agrif_ChildGrid_To_ParentGrid() 
     109!      CALL recompute_diags( kt ) 
     110!      CALL Agrif_ParentGrid_To_ChildGrid() 
     111 
    143112#endif 
    144       ! 
    145       ! Do recursive update: 
    146       IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update: 
    147          CALL Agrif_ChildGrid_To_ParentGrid() 
    148          CALL Agrif_Update_Dyn() 
    149          CALL Agrif_ParentGrid_To_ChildGrid() 
    150       ENDIF 
    151       ! 
     113 
    152114   END SUBROUTINE Agrif_Update_Dyn 
    153115 
    154 # if defined key_zdftke 
    155    SUBROUTINE Agrif_Update_Tke( kt ) 
    156       !!--------------------------------------------- 
    157       !!   *** ROUTINE Agrif_Update_Tke *** 
    158       !!--------------------------------------------- 
    159       !! 
     116   SUBROUTINE recompute_diags( kt ) 
     117      !!--------------------------------------------- 
     118      !!   *** ROUTINE recompute_diags *** 
     119      !!--------------------------------------------- 
    160120      INTEGER, INTENT(in) :: kt 
    161       !        
    162       IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN 
    163 #  if defined TWO_WAY 
    164  
    165       Agrif_UseSpecialValueInUpdate = .TRUE. 
    166       Agrif_SpecialValueFineGrid = 0. 
    167  
    168       CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  ) 
    169       CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT ) 
    170       CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM ) 
    171  
    172       Agrif_UseSpecialValueInUpdate = .FALSE. 
    173  
    174 #  endif 
    175        
    176    END SUBROUTINE Agrif_Update_Tke 
    177 # endif /* key_zdftke */ 
     121 
     122   END SUBROUTINE recompute_diags 
    178123 
    179124   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
    … …  
    182127      !!--------------------------------------------- 
    183128#  include "domzgr_substitute.h90" 
     129 
    184130      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    185131      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    186       LOGICAL, INTENT(in) :: before 
    187       !! 
     132      LOGICAL, iNTENT(in) :: before 
     133 
    188134      INTEGER :: ji,jj,jk,jn 
    189       !!--------------------------------------------- 
    190       ! 
     135 
    191136      IF (before) THEN 
    192137         DO jn = n1,n2 
    … …  
    201146      ELSE 
    202147         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    203             ! Add asselin part 
     148         ! Add asselin part 
    204149            DO jn = n1,n2 
    205150               DO jk=k1,k2 
    … …  
    208153                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
    209154                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) &  
    210                                  & + atfp * ( tabres(ji,jj,jk,jn) & 
    211                                  &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     155                              & + atfp * ( tabres(ji,jj,jk,jn) & 
     156                              &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
    212157                        ENDIF 
    213158                     ENDDO 
    … …  
    216161            ENDDO 
    217162         ENDIF 
     163 
    218164         DO jn = n1,n2 
    219165            DO jk=k1,k2 
    … …  
    228174         END DO 
    229175      ENDIF 
    230       !  
     176 
    231177   END SUBROUTINE updateTS 
    232178 
    … …  
    236182      !!--------------------------------------------- 
    237183#  include "domzgr_substitute.h90" 
    238       !! 
     184 
    239185      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    240186      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres 
    241187      LOGICAL, INTENT(in) :: before 
    242       !!  
     188 
    243189      INTEGER :: ji, jj, jk 
    244190      REAL(wp) :: zrhoy 
    245       !!--------------------------------------------- 
    246       !  
     191 
    247192      IF (before) THEN 
    248193         zrhoy = Agrif_Rhoy() 
    … …  
    264209                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    265210                     ub(ji,jj,jk) = ub(ji,jj,jk) &  
    266                            & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
     211                       & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk) 
    267212                  ENDIF 
    268213                  ! 
    … …  
    272217         END DO 
    273218      ENDIF 
    274       !  
     219 
    275220   END SUBROUTINE updateu 
    276221 
    … …  
    280225      !!--------------------------------------------- 
    281226#  include "domzgr_substitute.h90" 
    282       !! 
     227 
    283228      INTEGER :: i1,i2,j1,j2,k1,k2 
    284229      INTEGER :: ji,jj,jk 
    285230      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres 
    286231      LOGICAL :: before 
    287       !! 
     232 
    288233      REAL(wp) :: zrhox 
    289       !!---------------------------------------------       
    290       ! 
     234 
    291235      IF (before) THEN 
    292236         zrhox = Agrif_Rhox() 
    … …  
    308252                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part 
    309253                     vb(ji,jj,jk) = vb(ji,jj,jk) &  
    310                            & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
     254                       & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk) 
    311255                  ENDIF 
    312256                  ! 
    … …  
    316260         END DO 
    317261      ENDIF 
    318       !  
     262 
    319263   END SUBROUTINE updatev 
    320264 
    … …  
    324268      !!--------------------------------------------- 
    325269#  include "domzgr_substitute.h90" 
    326       !! 
     270 
    327271      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    328272      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    329273      LOGICAL, INTENT(in) :: before 
    330       !!  
     274 
    331275      INTEGER :: ji, jj, jk 
    332276      REAL(wp) :: zrhoy 
    333277      REAL(wp) :: zcorr 
    334       !!--------------------------------------------- 
    335       ! 
     278 
    336279      IF (before) THEN 
    337280         zrhoy = Agrif_Rhoy() 
    … …  
    383326         END DO 
    384327      ENDIF 
    385       ! 
     328 
    386329   END SUBROUTINE updateu2d 
    387330 
    … …  
    390333      !!          *** ROUTINE updatev2d *** 
    391334      !!--------------------------------------------- 
     335 
    392336      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    393337      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    394338      LOGICAL, INTENT(in) :: before 
    395       !!  
     339 
    396340      INTEGER :: ji, jj, jk 
    397341      REAL(wp) :: zrhox 
    398342      REAL(wp) :: zcorr 
    399       !!--------------------------------------------- 
    400       ! 
     343 
    401344      IF (before) THEN 
    402345         zrhox = Agrif_Rhox() 
    … …  
    448391         END DO 
    449392      ENDIF 
    450       !  
     393 
    451394   END SUBROUTINE updatev2d 
    452395 
    453  
    454396   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before ) 
    455397      !!--------------------------------------------- 
    456398      !!          *** ROUTINE updateSSH *** 
    457399      !!--------------------------------------------- 
     400#  include "domzgr_substitute.h90" 
     401 
    458402      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    459403      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    460404      LOGICAL, INTENT(in) :: before 
    461       !! 
     405 
    462406      INTEGER :: ji, jj 
    463       !!--------------------------------------------- 
    464       !  
     407 
    465408      IF (before) THEN 
    466409         DO jj=j1,j2 
    … …  
    470413         END DO 
    471414      ELSE 
     415 
    472416#if ! defined key_dynspg_ts 
    473417         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    474418            DO jj=j1,j2 
    475419               DO ji=i1,i2 
    476                   sshb(ji,jj) =   sshb(ji,jj) & 
    477                         & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
     420                sshb(ji,jj) =   sshb(ji,jj) & 
     421                 & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1) 
    478422               END DO 
    479423            END DO 
    … …  
    486430         END DO 
    487431      ENDIF 
    488       ! 
     432 
    489433   END SUBROUTINE updateSSH 
    490434 
    … …  
    493437      !!          *** ROUTINE updateub2b *** 
    494438      !!--------------------------------------------- 
     439 
    495440      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    496441      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    497442      LOGICAL, INTENT(in) :: before 
    498       !! 
     443 
    499444      INTEGER :: ji, jj 
    500445      REAL(wp) :: zrhoy 
    501       !!--------------------------------------------- 
    502       ! 
     446 
    503447      IF (before) THEN 
    504448         zrhoy = Agrif_Rhoy() 
    … …  
    516460         END DO 
    517461      ENDIF 
    518       ! 
     462 
    519463   END SUBROUTINE updateub2b 
    520464 
    … …  
    523467      !!          *** ROUTINE updatevb2b *** 
    524468      !!--------------------------------------------- 
     469 
    525470      INTEGER, INTENT(in) :: i1, i2, j1, j2 
    526471      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres 
    527472      LOGICAL, INTENT(in) :: before 
    528       !! 
     473 
    529474      INTEGER :: ji, jj 
    530475      REAL(wp) :: zrhox 
    531       !!--------------------------------------------- 
    532       ! 
     476 
    533477      IF (before) THEN 
    534478         zrhox = Agrif_Rhox() 
    … …  
    546490         END DO 
    547491      ENDIF 
    548       ! 
     492 
    549493   END SUBROUTINE updatevb2b 
    550  
    551  
    552    SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before ) 
    553       ! currently not used 
    554       !!--------------------------------------------- 
    555       !!           *** ROUTINE updateT *** 
    556       !!--------------------------------------------- 
    557 #  include "domzgr_substitute.h90" 
    558  
    559       INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    560       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    561       LOGICAL, iNTENT(in) :: before 
    562  
    563       INTEGER :: ji,jj,jk 
    564       REAL(wp) :: ztemp 
    565  
    566       IF (before) THEN 
    567          DO jk=k1,k2 
    568             DO jj=j1,j2 
    569                DO ji=i1,i2 
    570                   tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    571                   tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk) 
    572                   tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk) 
    573                END DO 
    574             END DO 
    575          END DO 
    576          tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy() 
    577          tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox() 
    578          tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy() 
    579       ELSE 
    580          DO jk=k1,k2 
    581             DO jj=j1,j2 
    582                DO ji=i1,i2 
    583                   IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN  
    584                      print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk) 
    585                      print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk) 
    586                      print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk) 
    587                      ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3))) 
    588                      print *,'CORR = ',ztemp-1. 
    589                      print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, & 
    590                            tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp 
    591                      e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp 
    592                      e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp 
    593                   END IF 
    594                END DO 
    595             END DO 
    596          END DO 
    597       ENDIF 
    598       ! 
    599    END SUBROUTINE update_scales 
    600  
    601 # if defined key_zdftke 
    602    SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before ) 
    603       !!--------------------------------------------- 
    604       !!           *** ROUTINE updateen *** 
    605       !!--------------------------------------------- 
    606       INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    607       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    608       LOGICAL, INTENT(in) :: before 
    609       !!--------------------------------------------- 
    610       ! 
    611       IF (before) THEN 
    612          ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2) 
    613       ELSE 
    614          en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
    615       ENDIF 
    616       ! 
    617    END SUBROUTINE updateEN 
    618  
    619  
    620    SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before ) 
    621       !!--------------------------------------------- 
    622       !!           *** ROUTINE updateavt *** 
    623       !!--------------------------------------------- 
    624       INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    625       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    626       LOGICAL, INTENT(in) :: before 
    627       !!--------------------------------------------- 
    628       ! 
    629       IF (before) THEN 
    630          ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2) 
    631       ELSE 
    632          avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
    633       ENDIF 
    634       ! 
    635    END SUBROUTINE updateAVT 
    636  
    637  
    638    SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before ) 
    639       !!--------------------------------------------- 
    640       !!           *** ROUTINE updateavm *** 
    641       !!--------------------------------------------- 
    642       INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2 
    643       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab 
    644       LOGICAL, INTENT(in) :: before 
    645       !!--------------------------------------------- 
    646       ! 
    647       IF (before) THEN 
    648          ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2) 
    649       ELSE 
    650          avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)  
    651       ENDIF 
    652       ! 
    653    END SUBROUTINE updateAVM 
    654  
    655 # endif /* key_zdftke */  
    656494 
    657495#else 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_top_interp.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_top_sponge.F90

    r6617 r6625  
    11#define SPONGE_TOP 
    22 
    3 MODULE agrif_top_sponge 
     3Module agrif_top_sponge 
    44#if defined key_agrif && defined key_top 
    55   USE par_oce 
    6    USE par_trc 
    76   USE oce 
    87   USE dom_oce 
    … …  
    1716   PRIVATE 
    1817 
    19    PUBLIC Agrif_Sponge_trc, interptrn_sponge 
     18   PUBLIC Agrif_Sponge_Trc, interptrn 
    2019 
    21    !! * Substitutions 
     20  !! * Substitutions 
    2221#  include "domzgr_substitute.h90" 
    2322   !!---------------------------------------------------------------------- 
    24    !! NEMO/NST 3.6 , NEMO Consortium (2010) 
     23   !! NEMO/NST 3.3 , NEMO Consortium (2010) 
    2524   !! $Id$ 
    2625   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    2726   !!---------------------------------------------------------------------- 
    2827 
    29 CONTAINS 
     28   CONTAINS 
    3029 
    31    SUBROUTINE Agrif_Sponge_trc 
     30   SUBROUTINE Agrif_Sponge_Trc 
    3231      !!--------------------------------------------- 
    3332      !!   *** ROUTINE Agrif_Sponge_Trc *** 
    3433      !!--------------------------------------------- 
    3534      !!  
     35      INTEGER :: ji,jj,jk,jn 
    3636      REAL(wp) :: timecoeff 
     37      REAL(wp) :: ztra, zabe1, zabe2, zbtr 
     38      REAL(wp), POINTER, DIMENSION(:,:) :: ztru, ztrv 
     39      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztabr 
     40      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: trbdiff 
    3741 
    3842#if defined SPONGE_TOP 
     43      CALL wrk_alloc( jpi, jpj, ztru, ztrv ) 
     44      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztabr, trbdiff ) 
     45 
    3946      timecoeff = REAL(Agrif_NbStepint(),wp)/Agrif_rhot() 
    40       CALL Agrif_sponge 
     47 
    4148      Agrif_SpecialValue=0. 
    4249      Agrif_UseSpecialValue = .TRUE. 
    43       tabspongedone_trn = .FALSE. 
    44       CALL Agrif_Bc_Variable(trn_sponge_id,calledweight=timecoeff,procname=interptrn_sponge) 
     50      ztabr = 0.e0 
     51      CALL Agrif_Bc_Variable(ztabr, tra_id,calledweight=timecoeff,procname=interptrn) 
    4552      Agrif_UseSpecialValue = .FALSE. 
     53 
     54      trbdiff(:,:,:,:) = trb(:,:,:,:) - ztabr(:,:,:,:) 
     55 
     56      CALL Agrif_sponge 
     57 
     58      DO jn = 1, jptra 
     59         DO jk = 1, jpkm1 
     60            ! 
     61            DO jj = 1, jpjm1 
     62               DO ji = 1, jpim1 
     63                  zabe1 = umask(ji,jj,jk) * spe1ur(ji,jj) * fse3u(ji,jj,jk) 
     64                  zabe2 = vmask(ji,jj,jk) * spe2vr(ji,jj) * fse3v(ji,jj,jk) 
     65                  ztru(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     66                  ztrv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
     67               ENDDO 
     68            ENDDO 
     69 
     70            DO jj = 2,jpjm1 
     71               DO ji = 2,jpim1 
     72                  zbtr = spbtr2(ji,jj) / fse3t(ji,jj,jk) 
     73                  ! horizontal diffusive trends 
     74                  ztra = zbtr * ( ztru(ji,jj) - ztru(ji-1,jj) + ztrv(ji,jj) - ztrv(ji,jj-1)  ) 
     75                  ! add it to the general tracer trends 
     76                  tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
     77               END DO 
     78            END DO 
     79            ! 
     80         ENDDO 
     81      ENDDO 
     82  
     83      CALL wrk_dealloc( jpi, jpj, ztru, ztrv ) 
     84      CALL wrk_dealloc( jpi, jpj, jpk, jptra, trbdiff, ztabr ) 
    4685 
    4786#endif 
    … …  
    4988   END SUBROUTINE Agrif_Sponge_Trc 
    5089 
    51    SUBROUTINE interptrn_sponge(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
     90   SUBROUTINE interptrn(tabres,i1,i2,j1,j2,k1,k2,n1,n2) 
    5291      !!--------------------------------------------- 
    53       !!   *** ROUTINE interptrn_sponge *** 
     92      !!   *** ROUTINE interptn *** 
    5493      !!--------------------------------------------- 
    5594      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    5695      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    57       LOGICAL, INTENT(in) :: before 
     96      ! 
     97      tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
    5898 
    59  
    60       INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices 
    61  
    62       REAL(wp) :: ztra, zabe1, zabe2, zbtr 
    63       REAL(wp), DIMENSION(i1:i2,j1:j2) :: ztu, ztv 
    64       REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2) ::trbdiff 
    65       ! 
    66       IF (before) THEN 
    67          tabres(i1:i2,j1:j2,k1:k2,n1:n2) = trn(i1:i2,j1:j2,k1:k2,n1:n2) 
    68       ELSE       
    69  
    70          trbdiff(:,:,:,:) = trb(i1:i2,j1:j2,:,:) - tabres(:,:,:,:)       
    71          DO jn = 1, jptra 
    72             DO jk = 1, jpkm1 
    73  
    74                DO jj = j1,j2-1 
    75                   DO ji = i1,i2-1 
    76                      zabe1 = fsaht_spu(ji,jj) * umask(ji,jj,jk) * re2u_e1u(ji,jj) * fse3u_n(ji,jj,jk) 
    77                      zabe2 = fsaht_spv(ji,jj) * vmask(ji,jj,jk) * re1v_e2v(ji,jj) * fse3v_n(ji,jj,jk) 
    78                      ztu(ji,jj) = zabe1 * ( trbdiff(ji+1,jj  ,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    79                      ztv(ji,jj) = zabe2 * ( trbdiff(ji  ,jj+1,jk,jn) - trbdiff(ji,jj,jk,jn) ) 
    80                   ENDDO 
    81                ENDDO 
    82  
    83                DO jj = j1+1,j2-1 
    84                   DO ji = i1+1,i2-1 
    85  
    86                      IF (.NOT. tabspongedone_trn(ji,jj)) THEN  
    87                         zbtr = r1_e12t(ji,jj) / fse3t(ji,jj,jk) 
    88                         ! horizontal diffusive trends 
    89                         ztra = zbtr * (  ztu(ji,jj) - ztu(ji-1,jj  ) + ztv(ji,jj) - ztv(ji  ,jj-1)  ) 
    90                         ! add it to the general tracer trends 
    91                         tra(ji,jj,jk,jn) = tra(ji,jj,jk,jn) + ztra 
    92                      ENDIF 
    93  
    94                   ENDDO 
    95                ENDDO 
    96  
    97             ENDDO 
    98          ENDDO 
    99  
    100          tabspongedone_trn(i1+1:i2-1,j1+1:j2-1) = .TRUE. 
    101       ENDIF 
    102       !                  
    103    END SUBROUTINE interptrn_sponge 
     99   END SUBROUTINE interptrn 
    104100 
    105101#else 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_top_update.F90

    r6617 r6625  
    11#define TWO_WAY 
    2 #undef DECAL_FEEDBACK 
    32 
    43MODULE agrif_top_update 
    … …  
    98   USE dom_oce 
    109   USE agrif_oce 
    11    USE par_trc 
    1210   USE trc 
    1311   USE wrk_nemo   
    … …  
    2624   !!---------------------------------------------------------------------- 
    2725 
    28 CONTAINS 
     26   CONTAINS 
    2927 
    3028   SUBROUTINE Agrif_Update_Trc( kt ) 
    … …  
    3230      !!   *** ROUTINE Agrif_Update_Trc *** 
    3331      !!--------------------------------------------- 
     32      !! 
    3433      INTEGER, INTENT(in) :: kt 
    35       !!--------------------------------------------- 
    36       !  
    37       IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
    38 #if defined TWO_WAY    
     34      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztra 
     35 
     36   
     37      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN 
     38 
     39#if defined TWO_WAY 
     40      CALL wrk_alloc( jpi, jpj, jpk, jptra, ztra ) 
     41 
    3942      Agrif_UseSpecialValueInUpdate = .TRUE. 
    4043      Agrif_SpecialValueFineGrid = 0. 
    41       !  
    42       IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
    43 # if ! defined DECAL_FEEDBACK 
    44          CALL Agrif_Update_Variable(trn_id, procname=updateTRC) 
    45 # else 
    46          CALL Agrif_Update_Variable(trn_id, locupdate=(/1,0/),procname=updateTRC) 
    47 # endif 
     44  
     45     IF (MOD(nbcline_trc,nbclineupdate) == 0) THEN 
     46         CALL Agrif_Update_Variable(ztra,trn_id, procname=updateTRC) 
    4847      ELSE 
    49 # if ! defined DECAL_FEEDBACK 
    50          CALL Agrif_Update_Variable(trn_id,locupdate=(/0,2/), procname=updateTRC) 
    51 # else 
    52          CALL Agrif_Update_Variable(trn_id,locupdate=(/1,2/), procname=updateTRC) 
    53 # endif 
     48         CALL Agrif_Update_Variable(ztra,trn_id,locupdate=(/0,2/), procname=updateTRC) 
    5449      ENDIF 
    55       ! 
     50 
    5651      Agrif_UseSpecialValueInUpdate = .FALSE. 
    5752      nbcline_trc = nbcline_trc + 1 
     53 
     54      CALL wrk_dealloc( jpi, jpj, jpk, jptra, ztra ) 
    5855#endif 
    59       ! 
     56 
    6057   END SUBROUTINE Agrif_Update_Trc 
    6158 
    62    SUBROUTINE updateTRC( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before ) 
     59   SUBROUTINE updateTRC(tabres,i1,i2,j1,j2,k1,k2,n1,n2,before) 
    6360      !!--------------------------------------------- 
    64       !!           *** ROUTINE updateT *** 
     61      !!   *** ROUTINE UpdateTrc *** 
    6562      !!--------------------------------------------- 
    66 #  include "domzgr_substitute.h90" 
    6763      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2 
    68       REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: ptab 
     64      REAL, DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres 
    6965      LOGICAL, INTENT(in) :: before 
    70       !! 
     66    
    7167      INTEGER :: ji,jj,jk,jn 
    72       !!--------------------------------------------- 
    73       ! 
    74       IF (before) THEN 
    75          DO jn = n1,n2 
    76             DO jk=k1,k2 
    77                DO jj=j1,j2 
    78                   DO ji=i1,i2 
    79                      ptab(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    80                   END DO 
    81                END DO 
    82             END DO 
    83          END DO 
    84       ELSE 
    85          IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
     68 
     69         IF( before ) THEN 
     70            DO jn = n1, n2 
     71               DO jk = k1, k2 
     72                  DO jj = j1, j2 
     73                     DO ji = i1, i2 
     74                        tabres(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
     75                     ENDDO 
     76                  ENDDO 
     77               ENDDO 
     78            ENDDO 
     79         ELSE 
     80            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN 
    8681            ! Add asselin part 
    87             DO jn = n1,n2 
    88                DO jk=k1,k2 
    89                   DO jj=j1,j2 
    90                      DO ji=i1,i2 
    91                         IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN 
    92                            trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
    93                                  & + atfp * ( ptab(ji,jj,jk,jn) & 
    94                                  &             - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     82               DO jn = n1, n2 
     83                  DO jk = k1, k2 
     84                     DO jj = j1, j2 
     85                        DO ji = i1, i2 
     86                           IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
     87                              trb(ji,jj,jk,jn) = trb(ji,jj,jk,jn) &  
     88                                 & + atfp * ( tabres(ji,jj,jk,jn) & 
     89                                               - trn(ji,jj,jk,jn) ) * tmask(ji,jj,jk) 
     90                           ENDIF 
     91                        ENDDO 
     92                     ENDDO 
     93                  ENDDO 
     94               ENDDO 
     95            ENDIF 
     96 
     97            DO jn = n1, n2 
     98               DO jk = k1, k2 
     99                  DO jj = j1, j2 
     100                     DO ji = i1, i2 
     101                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN 
     102                           trn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk) 
    95103                        ENDIF 
    96104                     ENDDO 
    … …  
    99107            ENDDO 
    100108         ENDIF 
    101          DO jn = n1,n2 
    102             DO jk=k1,k2 
    103                DO jj=j1,j2 
    104                   DO ji=i1,i2 
    105                      IF( ptab(ji,jj,jk,jn) .NE. 0. ) THEN  
    106                         trn(ji,jj,jk,jn) = ptab(ji,jj,jk,jn) * tmask(ji,jj,jk) 
    107                      END IF 
    108                   END DO 
    109                END DO 
    110             END DO 
    111          END DO 
    112       ENDIF 
    113       !  
     109 
    114110   END SUBROUTINE updateTRC 
    115111 
    … …  
    123119   END SUBROUTINE agrif_top_update_empty 
    124120#endif 
    125 END MODULE agrif_top_update 
     121END Module agrif_top_update 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/NST_SRC/agrif_user.F90

    r6617 r6625  
    1717   USE par_oce 
    1818   USE dom_oce 
     19   USE Agrif_Util 
    1920   USE nemogcm 
    2021   ! 
    … …  
    3031      jpi     = ( jpiglo-2*jpreci + (jpni-1+0) ) / jpni + 2*jpreci 
    3132      jpj     = ( jpjglo-2*jprecj + (jpnj-1+0) ) / jpnj + 2*jprecj 
    32 ! JC: change to allow for different vertical levels 
    33 !     jpk is already set 
    34 !     keep it jpk possibly different from jpkdta which  
    35 !     hold parent grid vertical levels number (set earlier) 
    36 !      jpk     = jpkdta  
     33      jpk     = jpkdta  
    3734      jpim1   = jpi-1  
    3835      jpjm1   = jpj-1  
    … …  
    6764   ! 0. Initializations 
    6865   !------------------- 
    69    IF( cp_cfg == 'orca' ) THEN 
     66   IF( cp_cfg == 'orca' ) then 
    7067      IF ( jp_cfg == 2 .OR. jp_cfg == 025 .OR. jp_cfg == 05 & 
    71             &                      .OR. jp_cfg == 4 ) THEN 
     68  &                      .OR. jp_cfg == 4 ) THEN 
    7269         jp_cfg = -1    ! set special value for jp_cfg on fine grids 
    7370         cp_cfg = "default" 
    … …  
    123120SUBROUTINE agrif_declare_var_dom 
    124121   !!---------------------------------------------------------------------- 
    125    !!                 *** ROUTINE agrif_declare_var *** 
     122   !!                 *** ROUTINE agrif_declarE_var *** 
    126123   !! 
    127124   !! ** Purpose :: Declaration of variables to be interpolated 
    128125   !!---------------------------------------------------------------------- 
    129126   USE agrif_util 
    130    USE par_oce        
     127   USE par_oce       !   ONLY : jpts 
    131128   USE oce 
    132129   IMPLICIT NONE 
    … …  
    135132   ! 1. Declaration of the type of variable which have to be interpolated 
    136133   !--------------------------------------------------------------------- 
    137    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e1u_id) 
    138    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),e2v_id) 
     134   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e1u_id) 
     135   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),e2v_id) 
     136 
    139137 
    140138   ! 2. Type of interpolation 
    141139   !------------------------- 
    142    CALL Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    143    CALL Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     140   Call Agrif_Set_bcinterp(e1u_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     141   Call Agrif_Set_bcinterp(e2v_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    144142 
    145143   ! 3. Location of interpolation 
    146144   !----------------------------- 
    147    CALL Agrif_Set_bc(e1u_id,(/0,0/)) 
    148    CALL Agrif_Set_bc(e2v_id,(/0,0/)) 
     145   Call Agrif_Set_bc(e1u_id,(/0,0/)) 
     146   Call Agrif_Set_bc(e2v_id,(/0,0/)) 
    149147 
    150148   ! 5. Update type 
    151149   !---------------  
    152    CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
    153    CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
    154  
    155 ! High order updates 
    156 !   CALL Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Average,            update2=Agrif_Update_Full_Weighting) 
    157 !   CALL Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Full_Weighting,     update2=Agrif_Update_Average) 
    158     ! 
     150   Call Agrif_Set_Updatetype(e1u_id,update1 = Agrif_Update_Copy, update2=Agrif_Update_Average) 
     151   Call Agrif_Set_Updatetype(e2v_id,update1 = Agrif_Update_Average, update2=Agrif_Update_Copy) 
     152 
    159153END SUBROUTINE agrif_declare_var_dom 
    160154 
    … …  
    173167   USE nemogcm 
    174168   USE sol_oce 
    175    USE lib_mpp 
    176169   USE in_out_manager 
    177170   USE agrif_opa_update 
    … …  
    181174   IMPLICIT NONE 
    182175   ! 
     176   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtstemp 
     177   REAL(wp), DIMENSION(:,:,:  ), ALLOCATABLE :: tabuvtemp 
     178   REAL(wp), DIMENSION(:,:    ), ALLOCATABLE :: tab2d 
    183179   LOGICAL :: check_namelist 
    184    CHARACTER(len=15) :: cl_check1, cl_check2, cl_check3 
    185    !!---------------------------------------------------------------------- 
     180   !!---------------------------------------------------------------------- 
     181 
     182   ALLOCATE( tabtstemp(jpi, jpj, jpk, jpts) ) 
     183   ALLOCATE( tabuvtemp(jpi, jpj, jpk)       ) 
     184   ALLOCATE( tab2d(jpi, jpj)                ) 
     185 
    186186 
    187187   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    193193   Agrif_SpecialValue=0. 
    194194   Agrif_UseSpecialValue = .TRUE. 
    195    CALL Agrif_Bc_variable(tsn_id,calledweight=1.,procname=interptsn) 
    196    CALL Agrif_Sponge 
    197    tabspongedone_tsn = .FALSE. 
    198    CALL Agrif_Bc_variable(tsn_sponge_id,calledweight=1.,procname=interptsn_sponge) 
    199    ! reset tsa to zero 
    200    tsa(:,:,:,:) = 0. 
    201  
    202    Agrif_UseSpecialValue = ln_spc_dyn 
    203    CALL Agrif_Bc_variable(un_interp_id,calledweight=1.,procname=interpun) 
    204    CALL Agrif_Bc_variable(vn_interp_id,calledweight=1.,procname=interpvn) 
    205    tabspongedone_u = .FALSE. 
    206    tabspongedone_v = .FALSE. 
    207    CALL Agrif_Bc_variable(un_sponge_id,calledweight=1.,procname=interpun_sponge) 
    208    tabspongedone_u = .FALSE. 
    209    tabspongedone_v = .FALSE. 
    210    CALL Agrif_Bc_variable(vn_sponge_id,calledweight=1.,procname=interpvn_sponge) 
    211  
    212 #if defined key_dynspg_ts 
    213    Agrif_UseSpecialValue = .TRUE. 
    214    CALL Agrif_Bc_variable(sshn_id,calledweight=1., procname=interpsshn ) 
    215  
    216    Agrif_UseSpecialValue = ln_spc_dyn 
    217    CALL Agrif_Bc_variable(unb_id,calledweight=1.,procname=interpunb) 
    218    CALL Agrif_Bc_variable(vnb_id,calledweight=1.,procname=interpvnb) 
    219    CALL Agrif_Bc_variable(ub2b_interp_id,calledweight=1.,procname=interpub2b) 
    220    CALL Agrif_Bc_variable(vb2b_interp_id,calledweight=1.,procname=interpvb2b) 
    221    ubdy_w(:) = 0.e0 ; vbdy_w(:) = 0.e0 ; hbdy_w(:) =0.e0 
    222    ubdy_e(:) = 0.e0 ; vbdy_e(:) = 0.e0 ; hbdy_e(:) =0.e0  
    223    ubdy_n(:) = 0.e0 ; vbdy_n(:) = 0.e0 ; hbdy_n(:) =0.e0  
    224    ubdy_s(:) = 0.e0 ; vbdy_s(:) = 0.e0 ; hbdy_s(:) =0.e0 
    225 #endif 
    226  
    227    Agrif_UseSpecialValue = .FALSE.  
    228    ! reset velocities to zero 
    229    ua(:,:,:) = 0. 
    230    va(:,:,:) = 0. 
     195   Call Agrif_Bc_variable(tabtstemp,tsn_id,calledweight=1.,procname=interptsn) 
     196   Call Agrif_Bc_variable(tabtstemp,tsa_id,calledweight=1.,procname=interptsn) 
     197 
     198   Call Agrif_Bc_variable(tabuvtemp,un_id,calledweight=1.,procname=interpu) 
     199   Call Agrif_Bc_variable(tabuvtemp,vn_id,calledweight=1.,procname=interpv) 
     200   Call Agrif_Bc_variable(tabuvtemp,ua_id,calledweight=1.,procname=interpun) 
     201   Call Agrif_Bc_variable(tabuvtemp,va_id,calledweight=1.,procname=interpvn) 
     202 
     203   Call Agrif_Bc_variable(tab2d,unb_id,calledweight=1.,procname=interpunb) 
     204   Call Agrif_Bc_variable(tab2d,vnb_id,calledweight=1.,procname=interpvnb) 
     205   Call Agrif_Bc_variable(tab2d,sshn_id,calledweight=1.,procname=interpsshn) 
     206   Agrif_UseSpecialValue = .FALSE. 
    231207 
    232208   ! 3. Some controls 
    233209   !----------------- 
    234    check_namelist = .TRUE. 
    235  
    236    IF( check_namelist ) THEN  
     210   check_namelist = .true. 
     211 
     212   IF( check_namelist ) THEN 
    237213 
    238214      ! Check time steps            
    239       IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
    240          WRITE(cl_check1,*)  NINT(Agrif_Parent(rdt)) 
    241          WRITE(cl_check2,*)  NINT(rdt) 
    242          WRITE(cl_check3,*)  NINT(Agrif_Parent(rdt)/Agrif_Rhot()) 
    243          CALL ctl_warn( 'incompatible time step between grids',   & 
    244                &               'parent grid value : '//cl_check1    ,   &  
    245                &               'child  grid value : '//cl_check2    ,   &  
    246                &               'value on child grid will be changed to : '//cl_check3 ) 
    247          rdt=Agrif_Parent(rdt)/Agrif_Rhot() 
     215      IF( NINT(Agrif_Rhot()) * nint(rdt) /= Agrif_Parent(rdt) ) THEN 
     216         WRITE(*,*) 'incompatible time step between grids' 
     217         WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
     218         WRITE(*,*) 'child  grid value : ',nint(rdt) 
     219         WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
     220         STOP 
    248221      ENDIF 
    249222 
    250223      ! Check run length 
    251224      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    252             Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
    253          WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    254          WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
    255          CALL ctl_warn( 'incompatible run length between grids'               ,   & 
    256                &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
    257                &              ' nitend on fine grid will be change to : '//cl_check2    ) 
    258          nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    259          nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
     225           Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
     226         WRITE(*,*) 'incompatible run length between grids' 
     227         WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
     228              Agrif_Parent(nit000)+1),' time step' 
     229         WRITE(*,*) 'child  grid value : ', & 
     230              (nitend-nit000+1),' time step' 
     231         WRITE(*,*) 'value on child grid should be : ', & 
     232              Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     233              Agrif_Parent(nit000)+1) 
     234         STOP 
    260235      ENDIF 
    261236 
    … …  
    263238      IF( ln_zps ) THEN 
    264239         ! check parameters for partial steps  
    265          IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
     240         IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
    266241            WRITE(*,*) 'incompatible e3zps_min between grids' 
    267242            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    278253         ENDIF 
    279254      ENDIF 
    280       ! check if masks and bathymetries match 
    281       IF(ln_chk_bathy) THEN 
    282          ! 
    283          IF(lwp) WRITE(numout,*) 'AGRIF: Check Bathymetry and masks near bdys. Level: ', Agrif_Level() 
    284          ! 
    285          kindic_agr = 0 
    286          ! check if umask agree with parent along western and eastern boundaries: 
    287          CALL Agrif_Bc_variable(umsk_id,calledweight=1.,procname=interpumsk) 
    288          ! check if vmask agree with parent along northern and southern boundaries: 
    289          CALL Agrif_Bc_variable(vmsk_id,calledweight=1.,procname=interpvmsk) 
    290     ! check if tmask and vertical scale factors agree with parent over first two coarse grid points: 
    291          CALL Agrif_Bc_variable(e3t_id,calledweight=1.,procname=interpe3t) 
    292          ! 
    293          IF (lk_mpp) CALL mpp_sum( kindic_agr ) 
    294          IF( kindic_agr /= 0 ) THEN                    
    295             CALL ctl_stop('Child Bathymetry is not correct near boundaries.') 
    296          ELSE 
    297             IF(lwp) WRITE(numout,*) 'Child Bathymetry is ok near boundaries.' 
    298          END IF 
    299       ENDIF 
    300       ! 
    301255   ENDIF 
    302    !  
    303    ! Do update at initialisation because not done before writing restarts 
    304    ! This would indeed change boundary conditions values at initial time 
    305    ! hence produce restartability issues. 
    306    ! Note that update below is recursive (with lk_agrif_doupd=T): 
    307    !  
    308 ! JC: I am not sure if Agrif_MaxLevel() is the "relative" 
    309 !     or the absolute maximum nesting level...TBC                         
    310    IF ( Agrif_Level().EQ.Agrif_MaxLevel() ) THEN  
    311       ! NB: Do tracers first, dynamics after because nbcline incremented in dynamics 
    312       CALL Agrif_Update_tra() 
    313       CALL Agrif_Update_dyn() 
    314    ENDIF 
    315    ! 
    316 # if defined key_zdftke 
    317 !   CALL Agrif_Update_tke(0) 
    318 # endif 
    319    ! 
    320    Agrif_UseSpecialValueInUpdate = .FALSE. 
     256 
     257   CALL Agrif_Update_tra(0) 
     258   CALL Agrif_Update_dyn(0) 
     259 
    321260   nbcline = 0 
    322    lk_agrif_doupd = .FALSE. 
     261   ! 
     262   DEALLOCATE(tabtstemp) 
     263   DEALLOCATE(tabuvtemp) 
     264   DEALLOCATE(tab2d) 
    323265   ! 
    324266END SUBROUTINE Agrif_InitValues_cont 
    … …  
    334276   USE par_oce       !   ONLY : jpts 
    335277   USE oce 
    336    USE agrif_oce 
    337278   IMPLICIT NONE 
    338279   !!---------------------------------------------------------------------- 
    … …  
    340281   ! 1. Declaration of the type of variable which have to be interpolated 
    341282   !--------------------------------------------------------------------- 
    342    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_id) 
    343    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jpts/),tsn_sponge_id) 
    344  
    345    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_interp_id) 
    346    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_interp_id) 
    347    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_update_id) 
    348    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_update_id) 
    349    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),un_sponge_id) 
    350    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vn_sponge_id) 
    351  
    352    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),e3t_id) 
    353    CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),umsk_id) 
    354    CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/nlci,nlcj,jpk/),vmsk_id) 
    355  
    356    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,3/),scales_t_id) 
    357  
    358    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),unb_id) 
    359    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vnb_id) 
    360    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_interp_id) 
    361    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_interp_id) 
    362    CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),ub2b_update_id) 
    363    CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),vb2b_update_id) 
    364  
    365    CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/nlci,nlcj/),sshn_id) 
    366  
    367 # if defined key_zdftke 
    368    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/), en_id) 
    369    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avt_id) 
    370    CALL agrif_declare_variable((/2,2,0/),(/3,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),avm_id) 
    371 # endif 
     283   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsn_id) 
     284   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsa_id) 
     285   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jpts/),tsb_id) 
     286 
     287   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),un_id) 
     288   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),vn_id) 
     289   CALL agrif_declare_variable((/1,2,0/),(/2,3,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),ua_id) 
     290   CALL agrif_declare_variable((/2,1,0/),(/3,2,0/),(/'x','y','N'/),(/1,1,1/),(/jpi,jpj,jpk/),va_id) 
     291 
     292   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),unb_id) 
     293   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vnb_id) 
     294   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),sshn_id) 
     295   CALL agrif_declare_variable((/2,2/),(/3,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),gcb_id) 
     296   CALL agrif_declare_variable((/1,2/),(/2,3/),(/'x','y'/),(/1,1/),(/jpi,jpj/),ub2b_id) 
     297   CALL agrif_declare_variable((/2,1/),(/3,2/),(/'x','y'/),(/1,1/),(/jpi,jpj/),vb2b_id) 
    372298 
    373299   ! 2. Type of interpolation 
    374300   !------------------------- 
    375301   CALL Agrif_Set_bcinterp(tsn_id,interp=AGRIF_linear) 
    376  
    377    CALL Agrif_Set_bcinterp(un_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    378    CALL Agrif_Set_bcinterp(vn_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    379  
    380    CALL Agrif_Set_bcinterp(tsn_sponge_id,interp=AGRIF_linear) 
     302   CALL Agrif_Set_bcinterp(tsa_id,interp=AGRIF_linear) 
     303 
     304   Call Agrif_Set_bcinterp(un_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     305   Call Agrif_Set_bcinterp(vn_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     306 
     307   Call Agrif_Set_bcinterp(ua_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     308   Call Agrif_Set_bcinterp(va_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    381309 
    382310   CALL Agrif_Set_bcinterp(sshn_id,interp=AGRIF_linear) 
    383    CALL Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    384    CALL Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    385    CALL Agrif_Set_bcinterp(ub2b_interp_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    386    CALL Agrif_Set_bcinterp(vb2b_interp_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    387  
    388  
    389    CALL Agrif_Set_bcinterp(un_sponge_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    390    CALL Agrif_Set_bcinterp(vn_sponge_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    391  
    392    CALL Agrif_Set_bcinterp(e3t_id,interp=AGRIF_constant) 
    393    CALL Agrif_Set_bcinterp(umsk_id,interp=AGRIF_constant) 
    394    CALL Agrif_Set_bcinterp(vmsk_id,interp=AGRIF_constant) 
    395  
    396 # if defined key_zdftke 
    397    CALL Agrif_Set_bcinterp(avm_id ,interp=AGRIF_linear) 
    398 # endif 
    399  
     311   Call Agrif_Set_bcinterp(unb_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     312   Call Agrif_Set_bcinterp(vnb_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     313   Call Agrif_Set_bcinterp(ub2b_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     314   Call Agrif_Set_bcinterp(vb2b_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    400315 
    401316   ! 3. Location of interpolation 
    402317   !----------------------------- 
    403    CALL Agrif_Set_bc(tsn_id,(/0,1/)) 
    404    CALL Agrif_Set_bc(un_interp_id,(/0,1/)) 
    405    CALL Agrif_Set_bc(vn_interp_id,(/0,1/)) 
    406  
    407 !   CALL Agrif_Set_bc(tsn_sponge_id,(/-3*Agrif_irhox(),0/)) 
    408 !   CALL Agrif_Set_bc(un_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
    409 !   CALL Agrif_Set_bc(vn_sponge_id,(/-2*Agrif_irhox()-1,0/)) 
    410    CALL Agrif_Set_bc(tsn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    411    CALL Agrif_Set_bc(un_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    412    CALL Agrif_Set_bc(vn_sponge_id ,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
    413  
    414    CALL Agrif_Set_bc(sshn_id,(/0,0/)) 
    415    CALL Agrif_Set_bc(unb_id ,(/0,0/)) 
    416    CALL Agrif_Set_bc(vnb_id ,(/0,0/)) 
    417    CALL Agrif_Set_bc(ub2b_interp_id,(/0,0/)) 
    418    CALL Agrif_Set_bc(vb2b_interp_id,(/0,0/)) 
    419  
    420    CALL Agrif_Set_bc(e3t_id,(/-2*Agrif_irhox()-1,0/))   ! if west and rhox=3: column 2 to 9 
    421    CALL Agrif_Set_bc(umsk_id,(/0,0/)) 
    422    CALL Agrif_Set_bc(vmsk_id,(/0,0/)) 
    423  
    424 # if defined key_zdftke 
    425    CALL Agrif_Set_bc(avm_id ,(/0,1/)) 
    426 # endif 
     318   Call Agrif_Set_bc(un_id,(/0,1/)) 
     319   Call Agrif_Set_bc(vn_id,(/0,1/)) 
     320 
     321   Call Agrif_Set_bc(sshn_id,(/0,1/)) 
     322   Call Agrif_Set_bc(unb_id,(/0,1/)) 
     323   Call Agrif_Set_bc(vnb_id,(/0,1/)) 
     324   Call Agrif_Set_bc(ub2b_id,(/0,1/)) 
     325   Call Agrif_Set_bc(vb2b_id,(/0,1/)) 
     326 
     327   Call Agrif_Set_bc(tsn_id,(/0,1/)) 
     328   Call Agrif_Set_bc(tsa_id,(/-3*Agrif_irhox(),0/)) 
     329 
     330   Call Agrif_Set_bc(ua_id,(/-2*Agrif_irhox(),0/)) 
     331   Call Agrif_Set_bc(va_id,(/-2*Agrif_irhox(),0/)) 
    427332 
    428333   ! 5. Update type 
    429334   !---------------  
    430    CALL Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
    431  
    432    CALL Agrif_Set_Updatetype(scales_t_id, update = AGRIF_Update_Average) 
    433  
    434    CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    435    CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    436  
    437    CALL Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
    438  
    439    CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    440    CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    441  
    442 # if defined key_zdftke 
    443    CALL Agrif_Set_Updatetype( en_id, update = AGRIF_Update_Average) 
    444    CALL Agrif_Set_Updatetype(avt_id, update = AGRIF_Update_Average) 
    445    CALL Agrif_Set_Updatetype(avm_id, update = AGRIF_Update_Average) 
    446 # endif 
    447  
    448 ! High order updates 
    449 !   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
    450 !   CALL Agrif_Set_Updatetype(un_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
    451 !   CALL Agrif_Set_Updatetype(vn_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
    452 ! 
    453 !   CALL Agrif_Set_Updatetype(ub2b_update_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Full_Weighting) 
    454 !   CALL Agrif_Set_Updatetype(vb2b_update_id,update1 = Agrif_Update_Full_Weighting, update2 = Agrif_Update_Average) 
    455 !   CALL Agrif_Set_Updatetype(sshn_id, update = Agrif_Update_Full_Weighting) 
    456   
    457    ! 
     335   Call Agrif_Set_Updatetype(tsn_id, update = AGRIF_Update_Average) 
     336   Call Agrif_Set_Updatetype(tsb_id, update = AGRIF_Update_Average) 
     337 
     338   Call Agrif_Set_Updatetype(sshn_id, update = AGRIF_Update_Average) 
     339   Call Agrif_Set_Updatetype(gcb_id,update = AGRIF_Update_Average) 
     340 
     341   Call Agrif_Set_Updatetype(un_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     342   Call Agrif_Set_Updatetype(vn_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     343 
     344   Call Agrif_Set_Updatetype(ub2b_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     345   Call Agrif_Set_Updatetype(vb2b_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     346 
    458347END SUBROUTINE agrif_declare_var 
    459348# endif 
    … …  
    476365   IMPLICIT NONE 
    477366   ! 
    478    !!---------------------------------------------------------------------- 
     367   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE :: zvel 
     368   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zadv 
     369   !!---------------------------------------------------------------------- 
     370 
     371   ALLOCATE( zvel(jpi,jpj), zadv(jpi,jpj,7)) 
    479372 
    480373   ! 1. Declaration of the type of variable which have to be interpolated 
    … …  
    508401   CALL Agrif_Update_lim2(0) 
    509402   ! 
     403   DEALLOCATE( zvel, zadv ) 
     404   ! 
    510405END SUBROUTINE Agrif_InitValues_cont_lim2 
    511406 
    … …  
    536431   !------------------------- 
    537432   CALL Agrif_Set_bcinterp(adv_ice_id ,interp=AGRIF_linear) 
    538    CALL Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
    539    CALL Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
     433   Call Agrif_Set_bcinterp(u_ice_id,interp1=Agrif_linear,interp2=AGRIF_ppm) 
     434   Call Agrif_Set_bcinterp(v_ice_id,interp1=AGRIF_ppm,interp2=Agrif_linear) 
    540435 
    541436   ! 3. Location of interpolation 
    542437   !----------------------------- 
    543    CALL Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
    544    CALL Agrif_Set_bc(u_ice_id,(/0,1/)) 
    545    CALL Agrif_Set_bc(v_ice_id,(/0,1/)) 
     438   Call Agrif_Set_bc(adv_ice_id ,(/0,1/)) 
     439   Call Agrif_Set_bc(u_ice_id,(/0,1/)) 
     440   Call Agrif_Set_bc(v_ice_id,(/0,1/)) 
    546441 
    547442   ! 5. Update type 
    548443   !--------------- 
    549    CALL Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
    550    CALL Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
    551    CALL Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
    552    !  
     444   Call Agrif_Set_Updatetype(adv_ice_id , update = AGRIF_Update_Average) 
     445   Call Agrif_Set_Updatetype(u_ice_id,update1 = Agrif_Update_Copy, update2 = Agrif_Update_Average) 
     446   Call Agrif_Set_Updatetype(v_ice_id,update1 = Agrif_Update_Average, update2 = Agrif_Update_Copy) 
     447 
    553448END SUBROUTINE agrif_declare_var_lim2 
    554449#  endif 
    … …  
    567462   USE nemogcm 
    568463   USE par_trc 
    569    USE lib_mpp 
    570464   USE trc 
    571465   USE in_out_manager 
    572    USE agrif_opa_sponge 
    573466   USE agrif_top_update 
    574467   USE agrif_top_interp 
    … …  
    577470   IMPLICIT NONE 
    578471   ! 
    579    CHARACTER(len=10) :: cl_check1, cl_check2, cl_check3 
     472   REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tabtrtemp 
    580473   LOGICAL :: check_namelist 
    581474   !!---------------------------------------------------------------------- 
     475 
     476   ALLOCATE( tabtrtemp(jpi,jpj,jpk,jptra) ) 
    582477 
    583478 
    … …  
    590485   Agrif_SpecialValue=0. 
    591486   Agrif_UseSpecialValue = .TRUE. 
    592    CALL Agrif_Bc_variable(trn_id,calledweight=1.,procname=interptrn) 
     487   Call Agrif_Bc_variable(tabtrtemp,trn_id,calledweight=1.,procname=interptrn) 
     488   Call Agrif_Bc_variable(tabtrtemp,tra_id,calledweight=1.,procname=interptrn) 
    593489   Agrif_UseSpecialValue = .FALSE. 
    594    CALL Agrif_Sponge 
    595    tabspongedone_trn = .FALSE. 
    596    CALL Agrif_Bc_variable(trn_sponge_id,calledweight=1.,procname=interptrn_sponge) 
    597    ! reset tsa to zero 
    598    tra(:,:,:,:) = 0. 
    599  
    600490 
    601491   ! 3. Some controls 
    602492   !----------------- 
    603    check_namelist = .TRUE. 
     493   check_namelist = .true. 
    604494 
    605495   IF( check_namelist ) THEN 
    606 # if defined key_offline 
     496#  if defined offline      
    607497      ! Check time steps 
    608       IF( NINT(Agrif_Rhot()) * NINT(rdt) .NE. Agrif_Parent(rdt) ) THEN 
    609          WRITE(cl_check1,*)  Agrif_Parent(rdt) 
    610          WRITE(cl_check2,*)  rdt 
    611          WRITE(cl_check3,*)  rdt*Agrif_Rhot() 
    612          CALL ctl_warn( 'incompatible time step between grids',   & 
    613                &               'parent grid value : '//cl_check1    ,   &  
    614                &               'child  grid value : '//cl_check2    ,   &  
    615                &               'value on child grid will be changed to  & 
    616                &               :'//cl_check3  ) 
    617          rdt=rdt*Agrif_Rhot() 
     498      IF( nint(Agrif_Rhot()) * nint(rdt) .ne. Agrif_Parent(rdt) ) THEN 
     499         WRITE(*,*) 'incompatible time step between grids' 
     500         WRITE(*,*) 'parent grid value : ',Agrif_Parent(rdt) 
     501         WRITE(*,*) 'child  grid value : ',nint(rdt) 
     502         WRITE(*,*) 'value on parent grid should be : ',rdt*Agrif_Rhot() 
     503         STOP 
    618504      ENDIF 
    619505 
    620506      ! Check run length 
    621507      IF( Agrif_IRhot() * (Agrif_Parent(nitend)- & 
    622             Agrif_Parent(nit000)+1) .NE. (nitend-nit000+1) ) THEN 
    623          WRITE(cl_check1,*)  (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    624          WRITE(cl_check2,*)   Agrif_Parent(nitend)   *Agrif_IRhot() 
    625          CALL ctl_warn( 'incompatible run length between grids'               ,   & 
    626                &              ' nit000 on fine grid will be change to : '//cl_check1,   & 
    627                &              ' nitend on fine grid will be change to : '//cl_check2    ) 
    628          nit000 = (Agrif_Parent(nit000)-1)*Agrif_IRhot() + 1 
    629          nitend =  Agrif_Parent(nitend)   *Agrif_IRhot() 
     508           Agrif_Parent(nit000)+1) .ne. (nitend-nit000+1) ) THEN 
     509         WRITE(*,*) 'incompatible run length between grids' 
     510         WRITE(*,*) 'parent grid value : ',(Agrif_Parent(nitend)- & 
     511              Agrif_Parent(nit000)+1),' time step' 
     512         WRITE(*,*) 'child  grid value : ', & 
     513              (nitend-nit000+1),' time step' 
     514         WRITE(*,*) 'value on child grid should be : ', & 
     515              Agrif_IRhot() * (Agrif_Parent(nitend)- & 
     516              Agrif_Parent(nit000)+1) 
     517         STOP 
    630518      ENDIF 
    631519 
    … …  
    633521      IF( ln_zps ) THEN 
    634522         ! check parameters for partial steps  
    635          IF( Agrif_Parent(e3zps_min) .NE. e3zps_min ) THEN 
     523         IF( Agrif_Parent(e3zps_min) .ne. e3zps_min ) THEN 
    636524            WRITE(*,*) 'incompatible e3zps_min between grids' 
    637525            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_min) 
    … …  
    640528            STOP 
    641529         ENDIF 
    642          IF( Agrif_Parent(e3zps_rat) .NE. e3zps_rat ) THEN 
     530         IF( Agrif_Parent(e3zps_rat) .ne. e3zps_rat ) THEN 
    643531            WRITE(*,*) 'incompatible e3zps_rat between grids' 
    644532            WRITE(*,*) 'parent grid :',Agrif_Parent(e3zps_rat) 
    … …  
    650538#  endif          
    651539      ! Check passive tracer cell 
    652       IF( nn_dttrc .NE. 1 ) THEN 
     540      IF( nn_dttrc .ne. 1 ) THEN 
    653541         WRITE(*,*) 'nn_dttrc should be equal to 1' 
    654542      ENDIF 
    655543   ENDIF 
    656544 
    657    CALL Agrif_Update_trc(0) 
    658    ! 
    659    Agrif_UseSpecialValueInUpdate = .FALSE. 
     545!ch   CALL Agrif_Update_trc(0) 
    660546   nbcline_trc = 0 
    661547   ! 
     548   DEALLOCATE(tabtrtemp) 
     549   ! 
    662550END SUBROUTINE Agrif_InitValues_cont_top 
    663551 
    … …  
    670558   !!---------------------------------------------------------------------- 
    671559   USE agrif_util 
    672    USE agrif_oce 
    673560   USE dom_oce 
    674561   USE trc 
    … …  
    678565   ! 1. Declaration of the type of variable which have to be interpolated 
    679566   !--------------------------------------------------------------------- 
    680    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_id) 
    681    CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/nlci,nlcj,jpk,jptra/),trn_sponge_id) 
     567   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trn_id) 
     568   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),trb_id) 
     569   CALL agrif_declare_variable((/2,2,0,0/),(/3,3,0,0/),(/'x','y','N','N'/),(/1,1,1,1/),(/jpi,jpj,jpk,jptra/),tra_id) 
    682570 
    683571   ! 2. Type of interpolation 
    684572   !------------------------- 
    685573   CALL Agrif_Set_bcinterp(trn_id,interp=AGRIF_linear) 
    686    CALL Agrif_Set_bcinterp(trn_sponge_id,interp=AGRIF_linear) 
     574   CALL Agrif_Set_bcinterp(tra_id,interp=AGRIF_linear) 
    687575 
    688576   ! 3. Location of interpolation 
    689577   !----------------------------- 
    690    CALL Agrif_Set_bc(trn_id,(/0,1/)) 
    691 !   CALL Agrif_Set_bc(trn_sponge_id,(/-3*Agrif_irhox(),0/)) 
    692    CALL Agrif_Set_bc(trn_sponge_id,(/-nn_sponge_len*Agrif_irhox()-1,0/)) 
     578   Call Agrif_Set_bc(trn_id,(/0,1/)) 
     579   Call Agrif_Set_bc(tra_id,(/-3*Agrif_irhox(),0/)) 
    693580 
    694581   ! 5. Update type 
    695582   !---------------  
    696    CALL Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
    697  
    698 !   Higher order update 
    699 !   CALL Agrif_Set_Updatetype(tsn_id, update = Agrif_Update_Full_Weighting) 
    700  
    701    ! 
     583   Call Agrif_Set_Updatetype(trn_id, update = AGRIF_Update_Average) 
     584   Call Agrif_Set_Updatetype(trb_id, update = AGRIF_Update_Average) 
     585 
     586 
    702587END SUBROUTINE agrif_declare_var_top 
    703588# endif 
    … …  
    707592   !!   *** ROUTINE Agrif_detect *** 
    708593   !!---------------------------------------------------------------------- 
     594   USE Agrif_Types 
    709595   ! 
    710596   INTEGER, DIMENSION(2) :: ksizex 
    … …  
    728614   ! 
    729615   INTEGER  ::   ios                 ! Local integer output status for namelist read 
    730    INTEGER  ::   iminspon 
    731    NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn, ln_chk_bathy 
    732    !!-------------------------------------------------------------------------------------- 
    733    ! 
    734    REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
    735    READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
    736 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
    737  
    738    REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
    739    READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
    740 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
    741    IF(lwm) WRITE ( numond, namagrif ) 
     616   NAMELIST/namagrif/ nn_cln_update, rn_sponge_tra, rn_sponge_dyn, ln_spc_dyn 
     617   !!---------------------------------------------------------------------- 
     618   ! 
     619      REWIND( numnam_ref )              ! Namelist namagrif in reference namelist : AGRIF zoom 
     620      READ  ( numnam_ref, namagrif, IOSTAT = ios, ERR = 901) 
     621901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in reference namelist', lwp ) 
     622 
     623      REWIND( numnam_cfg )              ! Namelist namagrif in configuration namelist : AGRIF zoom 
     624      READ  ( numnam_cfg, namagrif, IOSTAT = ios, ERR = 902 ) 
     625902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namagrif in configuration namelist', lwp ) 
     626      IF(lwm) WRITE ( numond, namagrif ) 
    742627   ! 
    743628   IF(lwp) THEN                    ! control print 
    … …  
    750635      WRITE(numout,*) '      sponge coefficient for dynamics   rn_sponge_tra = ', rn_sponge_dyn, ' s' 
    751636      WRITE(numout,*) '      use special values for dynamics   ln_spc_dyn    = ', ln_spc_dyn 
    752       WRITE(numout,*) '      check bathymetry                  ln_chk_bathy  = ', ln_chk_bathy 
    753637      WRITE(numout,*)  
    754638   ENDIF 
    … …  
    759643   visc_dyn      = rn_sponge_dyn 
    760644   ! 
    761    ! Check sponge length: 
    762    iminspon = MIN(FLOOR(REAL(jpiglo-4)/REAL(2*Agrif_irhox())), FLOOR(REAL(jpjglo-4)/REAL(2*Agrif_irhox())) ) 
    763    IF (lk_mpp) iminspon = MIN(iminspon,FLOOR(REAL(jpi-2)/REAL(Agrif_irhox())), FLOOR(REAL(jpj-2)/REAL(Agrif_irhox())) ) 
    764    IF (nn_sponge_len > iminspon)  CALL ctl_stop('agrif sponge length is too large') 
    765    ! 
    766    IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif agrif_oce_alloc: allocation of arrays failed') 
     645   IF( agrif_oce_alloc()  > 0 )   CALL ctl_warn('agrif sol_oce_alloc: allocation of arrays failed') 
    767646# if defined key_lim2 
    768647   IF( agrif_ice_alloc()  > 0 )   CALL ctl_stop('agrif agrif_ice_alloc: allocation of arrays failed') 
    … …  
    785664   SELECT CASE( i ) 
    786665   CASE(1)   ;   indglob = indloc + nimppt(nprocloc+1) - 1 
    787    CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1 
    788    CASE DEFAULT 
    789       indglob = indloc 
     666   CASE(2)   ;   indglob = indloc + njmppt(nprocloc+1) - 1  
     667   CASE(3)   ;   indglob = indloc 
     668   CASE(4)   ;   indglob = indloc 
    790669   END SELECT 
    791670   ! 
    792671END SUBROUTINE Agrif_InvLoc 
    793  
    794 SUBROUTINE Agrif_get_proc_info( imin, imax, jmin, jmax ) 
    795    !!---------------------------------------------------------------------- 
    796    !!                 *** ROUTINE Agrif_get_proc_info *** 
    797    !!---------------------------------------------------------------------- 
    798    USE par_oce 
    799    IMPLICIT NONE 
    800    ! 
    801    INTEGER, INTENT(out) :: imin, imax 
    802    INTEGER, INTENT(out) :: jmin, jmax 
    803    !!---------------------------------------------------------------------- 
    804    ! 
    805    imin = nimppt(Agrif_Procrank+1)  ! ????? 
    806    jmin = njmppt(Agrif_Procrank+1)  ! ????? 
    807    imax = imin + jpi - 1 
    808    jmax = jmin + jpj - 1 
    809    !  
    810 END SUBROUTINE Agrif_get_proc_info 
    811  
    812 SUBROUTINE Agrif_estimate_parallel_cost(imin, imax,jmin, jmax, nbprocs, grid_cost) 
    813    !!---------------------------------------------------------------------- 
    814    !!                 *** ROUTINE Agrif_estimate_parallel_cost *** 
    815    !!---------------------------------------------------------------------- 
    816    USE par_oce 
    817    IMPLICIT NONE 
    818    ! 
    819    INTEGER,  INTENT(in)  :: imin, imax 
    820    INTEGER,  INTENT(in)  :: jmin, jmax 
    821    INTEGER,  INTENT(in)  :: nbprocs 
    822    REAL(wp), INTENT(out) :: grid_cost 
    823    !!---------------------------------------------------------------------- 
    824    ! 
    825    grid_cost = REAL(imax-imin+1,wp)*REAL(jmax-jmin+1,wp) / REAL(nbprocs,wp) 
    826    ! 
    827 END SUBROUTINE Agrif_estimate_parallel_cost 
    828672 
    829673# endif 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OFF_SRC/dtadyn.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ASM/asminc.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdydta.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdydyn2d.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdyice_lim.F90

    r6617 r6625  
    107107      REAL(wp) ::   zwgt, zwgt1        ! local scalar 
    108108      REAL(wp) ::   ztmelts, zdh 
    109 #if  defined key_lim2 && ! defined key_lim2_vp && defined key_agrif 
    110      USE ice_2, vt_s => hsnm 
    111      USE ice_2, vt_i => hicm 
    112 #endif 
    113109 
    114110      !!------------------------------------------------------------------------------ 
    … …  
    119115      ! 
    120116#if defined key_lim2 
    121       DO jb = 1, idx%nblenrim(jgrd) 
     117      DO jb = 1, idx%nblen(jgrd) 
    122118         ji    = idx%nbi(jb,jgrd) 
    123119         jj    = idx%nbj(jb,jgrd) 
    … …  
    139135 
    140136      DO jl = 1, jpl 
    141          DO jb = 1, idx%nblenrim(jgrd) 
     137         DO jb = 1, idx%nblen(jgrd) 
    142138            ji    = idx%nbi(jb,jgrd) 
    143139            jj    = idx%nbj(jb,jgrd) 
    … …  
    175171 
    176172      DO jl = 1, jpl 
    177          DO jb = 1, idx%nblenrim(jgrd) 
     173         DO jb = 1, idx%nblen(jgrd) 
    178174            ji    = idx%nbi(jb,jgrd) 
    179175            jj    = idx%nbj(jb,jgrd) 
    … …  
    328324                
    329325               jgrd = 2      ! u velocity 
    330                DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
     326               DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
    331327                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    332328                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 
    … …  
    357353                
    358354               jgrd = 3      ! v velocity 
    359                DO jb = 1, idx_bdy(ib_bdy)%nblenrim(jgrd) 
     355               DO jb = 1, idx_bdy(ib_bdy)%nblen(jgrd) 
    360356                  ji    = idx_bdy(ib_bdy)%nbi(jb,jgrd) 
    361357                  jj    = idx_bdy(ib_bdy)%nbj(jb,jgrd) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdyini.F90

    r6617 r6625  
    7676      INTEGER  ::   ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices 
    7777      INTEGER  ::   icount, icountr, ibr_max, ilen1, ibm1  ! local integers 
    78       INTEGER  ::   iwe, ies, iso, ino, inum, id_dummy         !   -       - 
     78      INTEGER  ::   iw, ie, is, in, inum, id_dummy         !   -       - 
    7979      INTEGER  ::   igrd_start, igrd_end, jpbdta           !   -       - 
    8080      INTEGER  ::   jpbdtau, jpbdtas                       !   -       - 
    … …  
    777777!      is = mjg(1) + 1            ! if monotasking and no zoom, is=2 
    778778!      in = mjg(1) + nlcj-1 - 1   ! if monotasking and no zoom, in=jpjm1       
    779       iwe = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
    780       ies = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
    781       iso = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
    782       ino = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
     779      iw = mig(1) - jpizoom + 2         ! if monotasking and no zoom, iw=2 
     780      ie = mig(1) + nlci - jpizoom - 1  ! if monotasking and no zoom, ie=jpim1 
     781      is = mjg(1) - jpjzoom + 2         ! if monotasking and no zoom, is=2 
     782      in = mjg(1) + nlcj - jpjzoom - 1  ! if monotasking and no zoom, in=jpjm1 
    783783 
    784784      ALLOCATE( nbondi_bdy(nb_bdy)) 
    … …  
    853853               ENDIF 
    854854               ! check if point is in local domain 
    855                IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
    856                   & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino      ) THEN 
     855               IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
     856                  & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in       ) THEN 
    857857                  ! 
    858858                  icount = icount  + 1 
    … …  
    890890         com_south_b = 0 
    891891         com_north_b = 0 
    892  
    893892         DO igrd = 1, jpbgrd 
    894893            icount  = 0 
    … …  
    897896               DO ib = 1, nblendta(igrd,ib_bdy) 
    898897                  ! check if point is in local domain and equals ir 
    899                   IF(  nbidta(ib,igrd,ib_bdy) >= iwe .AND. nbidta(ib,igrd,ib_bdy) <= ies .AND.   & 
    900                      & nbjdta(ib,igrd,ib_bdy) >= iso .AND. nbjdta(ib,igrd,ib_bdy) <= ino .AND.   & 
     898                  IF(  nbidta(ib,igrd,ib_bdy) >= iw .AND. nbidta(ib,igrd,ib_bdy) <= ie .AND.   & 
     899                     & nbjdta(ib,igrd,ib_bdy) >= is .AND. nbjdta(ib,igrd,ib_bdy) <= in .AND.   & 
    901900                     & nbrdta(ib,igrd,ib_bdy) == ir  ) THEN 
    902901                     ! 
    … …  
    15951594            ELSE 
    15961595               ! This is a corner 
    1597                IF(lwp) WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
     1596               WRITE(numout,*) 'Found a South-West corner at (i,j): ', jpiwob(ib), jpjwdt(ib) 
    15981597               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,1)) 
    15991598               itest=itest+1 
    … …  
    16091608            ELSE 
    16101609               ! This is a corner 
    1611                IF(lwp) WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
     1610               WRITE(numout,*) 'Found a North-West corner at (i,j): ', jpiwob(ib), jpjwft(ib) 
    16121611               CALL bdy_ctl_corn(npckgw(ib), icornw(ib,2)) 
    16131612               itest=itest+1 
    … …  
    16391638            ELSE 
    16401639               ! This is a corner 
    1641                IF(lwp) WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
     1640               WRITE(numout,*) 'Found a South-East corner at (i,j): ', jpieob(ib)+1, jpjedt(ib) 
    16421641               CALL bdy_ctl_corn(npckge(ib), icorne(ib,1)) 
    16431642               itest=itest+1 
    … …  
    16531652            ELSE 
    16541653               ! This is a corner 
    1655                IF(lwp) WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
     1654               WRITE(numout,*) 'Found a North-East corner at (i,j): ', jpieob(ib)+1, jpjeft(ib) 
    16561655               CALL bdy_ctl_corn(npckge(ib), icorne(ib,2)) 
    16571656               itest=itest+1 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdytides.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/BDY/bdyvol.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DIA/diaharm.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DIA/diahsb.F90

    r6617 r6625  
    9393      ! 1 - Trends due to forcing ! 
    9494      ! ------------------------- ! 
    95       z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
     95      z_frc_trd_v = r1_rau0 * glob_sum( - ( emp(:,:) - rnf(:,:) + rdivisf * fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes 
    9696      z_frc_trd_t =           glob_sum( sbc_tsc(:,:,jp_tem) * surf(:,:) )                               ! heat fluxes 
    9797      z_frc_trd_s =           glob_sum( sbc_tsc(:,:,jp_sal) * surf(:,:) )                               ! salt fluxes 
    … …  
    101101      ! Add ice shelf heat & salt input 
    102102      IF( nn_isf .GE. 1 )  THEN 
    103           z_frc_trd_t = z_frc_trd_t + glob_sum( risf_tsc(:,:,jp_tem) * surf(:,:) ) 
    104           z_frc_trd_s = z_frc_trd_s + glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
     103          z_frc_trd_t = z_frc_trd_t & 
     104              &   + glob_sum( ( risf_tsc(:,:,jp_tem) - rdivisf * fwfisf(:,:) * (-1.9) * r1_rau0 ) * surf(:,:) ) 
     105          z_frc_trd_s = z_frc_trd_s + (1.0_wp - rdivisf) * glob_sum( risf_tsc(:,:,jp_sal) * surf(:,:) ) 
    105106      ENDIF 
    106107 
    … …  
    199200!      ENDIF 
    200201!!gm end 
     202 
    201203 
    202204      IF( lk_vvl ) THEN 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DIA/diawri.F90

    r6617 r6625  
    145145      ENDIF 
    146146 
    147       ! Output of initial vertical scale factor 
    148       CALL iom_put("e3t_0", e3t_0(:,:,:) ) 
    149       CALL iom_put("e3u_0", e3t_0(:,:,:) ) 
    150       CALL iom_put("e3v_0", e3t_0(:,:,:) ) 
    151       ! 
    152       CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
    153       CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
    154       CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
    155       CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
    156       IF( iom_use("e3tdef") )   & 
    157          CALL iom_put( "e3tdef"  , ( ( fse3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) 
    158  
     147      IF( .NOT.lk_vvl ) THEN 
     148         CALL iom_put( "e3t" , fse3t_n(:,:,:) ) 
     149         CALL iom_put( "e3u" , fse3u_n(:,:,:) ) 
     150         CALL iom_put( "e3v" , fse3v_n(:,:,:) ) 
     151         CALL iom_put( "e3w" , fse3w_n(:,:,:) ) 
     152      ENDIF 
    159153 
    160154      CALL iom_put( "ssh" , sshn )                 ! sea surface height 
     155      if( iom_use('ssh2') )   CALL iom_put( "ssh2", sshn(:,:) * sshn(:,:) )   ! square of sea surface height 
    161156       
    162157      CALL iom_put( "toce", tsn(:,:,:,jp_tem) )    ! 3D temperature 
    … …  
    248243      CALL iom_put( "avm" , avmu                       )    ! T vert. eddy visc. coef. 
    249244      CALL iom_put( "avs" , fsavs(:,:,:)               )    ! S vert. eddy diff. coef. (useful only with key_zdfddm) 
    250                                                             ! Log of eddy diff coef 
    251       IF( iom_use('logavt') )   CALL iom_put( "logavt", LOG( MAX( 1.e-20_wp, avt  (:,:,:) ) ) ) 
    252       IF( iom_use('logavs') )   CALL iom_put( "logavs", LOG( MAX( 1.e-20_wp, fsavs(:,:,:) ) ) ) 
    253245 
    254246      IF ( iom_use("sstgrad") .OR. iom_use("sstgrad2") ) THEN 
    … …  
    315307         CALL iom_put( "eken", rke )            
    316308      ENDIF 
    317       ! 
    318       CALL iom_put( "hdiv", hdivn )                  ! Horizontal divergence 
    319       ! 
     309          
    320310      IF( iom_use("u_masstr") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN 
    321311         z3d(:,:,jpk) = 0.e0 
    … …  
    448438      zdt = rdt 
    449439      IF( nacc == 1 ) zdt = rdtmin 
    450       clop = "x"         ! no use of the mask value (require less cpu time, and otherwise the model crashes) 
     440      IF( ln_mskland )   THEN   ;   clop = "only(x)"   ! put 1.e+20 on land (very expensive!!) 
     441      ELSE                      ;   clop = "x"         ! no use of the mask value (require less cpu time) 
     442      ENDIF 
    451443#if defined key_diainstant 
    452444      zsto = nwrite * zdt 
    … …  
    10281020         CALL histdef( id_i, "vovvldep", "T point depth"         , "m"      ,   &   ! t-point depth 
    10291021            &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    1030          CALL histdef( id_i, "vovvle3t", "T point thickness"         , "m"      ,   &   ! t-point depth 
    1031             &          jpi, jpj, nh_i, jpk, 1, jpk, nz_i, 32, clop, zsto, zout ) 
    10321022      END IF 
    10331023 
    … …  
    10601050      CALL histwrite( id_i, "sozotaux", kt, utau             , jpi*jpj    , idex )    ! i-wind stress 
    10611051      CALL histwrite( id_i, "sometauy", kt, vtau             , jpi*jpj    , idex )    ! j-wind stress 
    1062       IF( lk_vvl ) THEN 
    1063          CALL histwrite( id_i, "vovvldep", kt, fsdept_n(:,:,:), jpi*jpj*jpk, idex )!  T-cell depth        
    1064          CALL histwrite( id_i, "vovvle3t", kt, fse3t_n (:,:,:), jpi*jpj*jpk, idex )!  T-cell thickness   
    1065       END IF 
    10661052 
    10671053      ! 3. Close the file 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/daymod.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/domhgr.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/domwri.F90

    r6617 r6625  
    215215         CALL iom_rstput( 0, 0, inum4, 'gdept_1d' , gdept_1d )  !    ! stretched system 
    216216         CALL iom_rstput( 0, 0, inum4, 'gdepw_1d' , gdepw_1d ) 
    217          CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0, ktype = jp_r4 )      
    218          CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0, ktype = jp_r4 )      
    219217      ENDIF 
    220218       

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DOM/domzgr.F90

    r6617 r6625  
    219219         &  ppsur == pp_to_be_computed           ) THEN 
    220220         ! 
    221 #if defined key_agrif 
    222          za1  = (  ppdzmin - pphmax / FLOAT(jpkdta-1)  )                                                   & 
    223             & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpkdta-1) * (  LOG( COSH( (jpkdta - ppkth) / ppacr) )& 
    224             &                                                      - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
    225 #else 
    226221         za1  = (  ppdzmin - pphmax / FLOAT(jpkm1)  )                                                      & 
    227222            & / ( TANH((1-ppkth)/ppacr) - ppacr/FLOAT(jpk-1) * (  LOG( COSH( (jpk - ppkth) / ppacr) )      & 
    228223            &                                                   - LOG( COSH( ( 1  - ppkth) / ppacr) )  )  ) 
    229 #endif 
    230224         za0  = ppdzmin - za1 *              TANH( (1-ppkth) / ppacr ) 
    231225         zsur =   - za0 - za1 * ppacr * LOG( COSH( (1-ppkth) / ppacr )  ) 
    … …  
    242236              WRITE(numout,*) '            Uniform grid with ',jpk-1,' layers' 
    243237              WRITE(numout,*) '            Total depth    :', zhmax 
    244 #if defined key_agrif 
    245               WRITE(numout,*) '            Layer thickness:', zhmax/(jpkdta-1) 
    246 #else 
    247238              WRITE(numout,*) '            Layer thickness:', zhmax/(jpk-1) 
    248 #endif 
    249239         ELSE 
    250240            IF( ppa1 == 0._wp .AND. ppa0 == 0._wp .AND. ppsur == 0._wp ) THEN 
    … …  
    270260      ! Reference z-coordinate (depth - scale factor at T- and W-points) 
    271261      ! ====================== 
    272       IF( ppkth == 0._wp ) THEN            !  uniform vertical grid  
    273 #if defined key_agrif 
    274          za1 = zhmax / FLOAT(jpkdta-1)  
    275 #else 
     262      IF( ppkth == 0._wp ) THEN            !  uniform vertical grid        
    276263         za1 = zhmax / FLOAT(jpk-1)  
    277 #endif 
    278264         DO jk = 1, jpk 
    279265            zw = FLOAT( jk ) 
    … …  
    18841870             iim1 = MAX( ji-1, 1 ) 
    18851871             ijm1 = MAX( jj-1, 1 ) 
    1886              IF( ( + bathy(iim1,ijp1) + bathy(ji,ijp1) + bathy(iip1,ijp1)  & 
    1887                 &  + bathy(iim1,jj  )                  + bathy(iip1,jj  )  & 
    1888                 &  + bathy(iim1,ijm1) + bathy(ji,ijm1) + bathy(iip1,ijp1)  ) > 0._wp ) THEN 
    1889                 zenv(ji,jj) = rn_sbot_min 
     1872             IF( (bathy(iip1,jj) + bathy(iim1,jj) + bathy(ji,ijp1) + bathy(ji,ijm1) +              & 
     1873        &         bathy(iip1,ijp1) + bathy(iim1,ijm1) + bathy(iip1,ijp1) + bathy(iim1,ijm1)) > 0._wp ) THEN 
     1874               zenv(ji,jj) = rn_sbot_min 
    18901875             ENDIF 
    18911876           ENDIF 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DYN/divcur.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DYN/dynnxt.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_ts.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/DYN/sshwzv.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/IOM/iom.F90

    r6617 r6625  
    9494      CHARACTER(len=*), INTENT(in)  :: cdname 
    9595#if defined key_iomput 
    96 #if ! defined key_xios2 
    97       TYPE(xios_time)     :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
    98       CHARACTER(len=19)   :: cldate  
    99 #else 
    100       TYPE(xios_duration) :: dtime    = xios_duration(0, 0, 0, 0, 0, 0) 
    101       TYPE(xios_date)     :: start_date 
    102 #endif 
    103       CHARACTER(len=10)   :: clname 
    104       INTEGER             :: ji 
     96      TYPE(xios_time)   :: dtime    = xios_time(0, 0, 0, 0, 0, 0) 
     97      CHARACTER(len=19) :: cldate  
     98      CHARACTER(len=10) :: clname 
     99      INTEGER           ::   ji 
    105100      ! 
    106101      REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z_bnds 
    107102      !!---------------------------------------------------------------------- 
    108 #if ! defined key_xios2 
     103 
    109104      ALLOCATE( z_bnds(jpk,2) ) 
    110 #else 
    111       ALLOCATE( z_bnds(2,jpk) ) 
    112 #endif 
    113105 
    114106      clname = cdname 
    … …  
    118110 
    119111      ! calendar parameters 
    120 #if ! defined key_xios2 
    121112      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    122113      CASE ( 1)   ;   CALL xios_set_context_attr(TRIM(clname), calendar_type= "Gregorian") 
    … …  
    126117      WRITE(cldate,"(i4.4,'-',i2.2,'-',i2.2,' 00:00:00')") nyear,nmonth,nday  
    127118      CALL xios_set_context_attr(TRIM(clname), start_date=cldate ) 
    128 #else 
    129       ! Calendar type is now defined in xml file  
    130       SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    131       CASE ( 1)   ; CALL xios_define_calendar( TYPE = "Gregorian", time_origin = xios_date(1900,01,01,00,00,00), & 
    132           &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
    133       CASE ( 0)   ; CALL xios_define_calendar( TYPE = "NoLeap"   , time_origin = xios_date(1900,01,01,00,00,00), & 
    134           &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
    135       CASE (30)   ; CALL xios_define_calendar( TYPE = "D360"     , time_origin = xios_date(1900,01,01,00,00,00), & 
    136           &                                    start_date = xios_date(nyear,nmonth,nday,0,0,0) ) 
    137       END SELECT 
    138 #endif 
     119 
    139120      ! horizontal grid definition 
    140  
    141121      CALL set_scalar 
    142122 
    … …  
    190170 
    191171      ! Add vertical grid bounds 
    192 #if ! defined key_xios2 
    193172      z_bnds(:      ,1) = gdepw_1d(:) 
    194173      z_bnds(1:jpkm1,2) = gdepw_1d(2:jpk) 
    195174      z_bnds(jpk:   ,2) = gdepw_1d(jpk) + e3t_1d(jpk) 
    196 #else 
    197       z_bnds(1      ,:) = gdepw_1d(:) 
    198       z_bnds(2,1:jpkm1) = gdepw_1d(2:jpk) 
    199       z_bnds(2,jpk:   ) = gdepw_1d(jpk) + e3t_1d(jpk) 
    200 #endif 
    201  
    202175      CALL iom_set_axis_attr( "deptht", bounds=z_bnds ) 
    203176      CALL iom_set_axis_attr( "depthu", bounds=z_bnds ) 
    204177      CALL iom_set_axis_attr( "depthv", bounds=z_bnds ) 
    205  
    206 #if ! defined key_xios2 
    207       z_bnds(:    ,2)  = gdept_1d(:) 
    208       z_bnds(2:jpk,1)  = gdept_1d(1:jpkm1) 
    209       z_bnds(1    ,1)  = gdept_1d(1) - e3w_1d(1) 
    210 #else 
    211       z_bnds(2,:    )  = gdept_1d(:) 
    212       z_bnds(1,2:jpk)  = gdept_1d(1:jpkm1) 
    213       z_bnds(1,1    )  = gdept_1d(1) - e3w_1d(1) 
    214 #endif 
     178      z_bnds(:    ,2) = gdept_1d(:) 
     179      z_bnds(2:jpk,1) = gdept_1d(1:jpkm1) 
     180      z_bnds(1    ,1) = gdept_1d(1) - e3w_1d(1) 
    215181      CALL iom_set_axis_attr( "depthw", bounds=z_bnds ) 
    216  
    217182 
    218183# if defined key_floats 
    … …  
    11911156      REAL(wp), DIMENSION(:)   , OPTIONAL, INTENT(in) ::   lonvalue, latvalue 
    11921157      REAL(wp), DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   bounds_lon, bounds_lat, area 
    1193 #if ! defined key_xios2 
    1194      LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
    1195 #else 
    1196       LOGICAL,  DIMENSION(:) , OPTIONAL, INTENT(in) ::   mask 
    1197 #endif 
    1198  
    1199 #if ! defined key_xios2 
     1158      LOGICAL,  DIMENSION(:,:) , OPTIONAL, INTENT(in) ::   mask 
     1159 
    12001160      IF ( xios_is_valid_domain     (cdid) ) THEN 
    12011161         CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    12041164            &    lonvalue=lonvalue, latvalue=latvalue, mask=mask, nvertex=nvertex, bounds_lon=bounds_lon,                  & 
    12051165            &    bounds_lat=bounds_lat, area=area ) 
    1206      ENDIF 
     1166      ENDIF 
     1167 
    12071168      IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    12081169         CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    … …  
    12121173            &    bounds_lat=bounds_lat, area=area ) 
    12131174      ENDIF 
    1214  
    1215 #else 
    1216       IF ( xios_is_valid_domain     (cdid) ) THEN 
    1217          CALL xios_set_domain_attr     ( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    1218             &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    1219             &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
    1220             &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear') 
    1221      ENDIF 
    1222       IF ( xios_is_valid_domaingroup(cdid) ) THEN 
    1223          CALL xios_set_domaingroup_attr( cdid, ni_glo=ni_glo, nj_glo=nj_glo, ibegin=ibegin, jbegin=jbegin, ni=ni, nj=nj,   & 
    1224             &    data_dim=data_dim, data_ibegin=data_ibegin, data_ni=data_ni, data_jbegin=data_jbegin, data_nj=data_nj ,   & 
    1225             &    lonvalue_1D=lonvalue, latvalue_1D=latvalue, mask_1D=mask, nvertex=nvertex, bounds_lon_1D=bounds_lon,                  & 
    1226             &    bounds_lat_1D=bounds_lat, area=area, type='curvilinear' ) 
    1227       ENDIF 
    1228 #endif 
    12291175      CALL xios_solve_inheritance() 
    12301176 
    12311177   END SUBROUTINE iom_set_domain_attr 
    1232  
    1233 #if defined key_xios2 
    1234   SUBROUTINE iom_set_zoom_domain_attr( cdid, ibegin, jbegin, ni, nj) 
    1235      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    1236      INTEGER                  , OPTIONAL, INTENT(in) ::   ibegin, jbegin, ni, nj 
    1237  
    1238      IF ( xios_is_valid_zoom_domain     (cdid) ) THEN 
    1239          CALL xios_set_zoom_domain_attr     ( cdid, ibegin=ibegin, jbegin=jbegin, ni=ni,    & 
    1240            &   nj=nj) 
    1241     ENDIF 
    1242   END SUBROUTINE iom_set_zoom_domain_attr 
    1243 #endif 
    12441178 
    12451179 
    … …  
    12491183      REAL(wp), DIMENSION(:,:), OPTIONAL, INTENT(in) ::   bounds 
    12501184      IF ( PRESENT(paxis) ) THEN 
    1251 #if ! defined key_xios2 
    12521185         IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, size=SIZE(paxis), value=paxis ) 
    12531186         IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, size=SIZE(paxis), value=paxis ) 
    1254 #else 
    1255          IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1256          IF ( xios_is_valid_axisgroup(cdid) )   CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) 
    1257 #endif 
    12581187      ENDIF 
    12591188      IF ( xios_is_valid_axis     (cdid) )   CALL xios_set_axis_attr     ( cdid, bounds=bounds ) 
    … …  
    12621191   END SUBROUTINE iom_set_axis_attr 
    12631192 
     1193 
    12641194   SUBROUTINE iom_set_field_attr( cdid, freq_op, freq_offset ) 
    12651195      CHARACTER(LEN=*)          , INTENT(in) ::   cdid 
    1266 #if ! defined key_xios2 
    1267       CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_op 
    1268       CHARACTER(LEN=*)   ,OPTIONAL , INTENT(in) ::   freq_offset 
    1269 #else 
    1270       TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_op 
    1271       TYPE(xios_duration),OPTIONAL , INTENT(in) ::   freq_offset 
    1272 #endif 
    1273       IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr       & 
    1274     &     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    1275       IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr  & 
    1276     &                    ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1196      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_op 
     1197      CHARACTER(LEN=*),OPTIONAL , INTENT(in) ::   freq_offset 
     1198      IF ( xios_is_valid_field     (cdid) )   CALL xios_set_field_attr     ( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
     1199      IF ( xios_is_valid_fieldgroup(cdid) )   CALL xios_set_fieldgroup_attr( cdid, freq_op=freq_op, freq_offset=freq_offset ) 
    12771200      CALL xios_solve_inheritance() 
    12781201   END SUBROUTINE iom_set_field_attr 
     1202 
    12791203 
    12801204   SUBROUTINE iom_set_file_attr( cdid, name, name_suffix ) 
    … …  
    12891213   SUBROUTINE iom_get_file_attr( cdid, name, name_suffix, output_freq ) 
    12901214      CHARACTER(LEN=*)          , INTENT(in ) ::   cdid 
    1291       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix 
    1292 #if ! defined key_xios2 
    1293       CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::    output_freq 
    1294 #else 
    1295       TYPE(xios_duration)   ,OPTIONAL , INTENT(out) :: output_freq 
    1296 #endif   
     1215      CHARACTER(LEN=*),OPTIONAL , INTENT(out) ::   name, name_suffix, output_freq 
    12971216      LOGICAL                                 ::   llexist1,llexist2,llexist3 
    12981217      !--------------------------------------------------------------------- 
    12991218      IF( PRESENT( name        ) )   name = ''          ! default values 
    13001219      IF( PRESENT( name_suffix ) )   name_suffix = '' 
    1301 #if ! defined key_xios2 
    13021220      IF( PRESENT( output_freq ) )   output_freq = '' 
    1303 #else 
    1304       IF( PRESENT( output_freq ) )   output_freq = xios_duration(0,0,0,0,0,0) 
    1305 #endif 
    13061221      IF ( xios_is_valid_file     (cdid) ) THEN 
    13071222         CALL xios_solve_inheritance() 
    … …  
    13241239      CHARACTER(LEN=*)                   , INTENT(in) ::   cdid 
    13251240      LOGICAL, DIMENSION(:,:,:), OPTIONAL, INTENT(in) ::   mask 
    1326 #if ! defined key_xios2 
    13271241      IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask=mask ) 
    13281242      IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask=mask ) 
    1329 #else 
    1330       IF ( xios_is_valid_grid     (cdid) )   CALL xios_set_grid_attr     ( cdid, mask_3D=mask ) 
    1331       IF ( xios_is_valid_gridgroup(cdid) )   CALL xios_set_gridgroup_attr( cdid, mask_3D=mask ) 
    1332 #endif 
    13331243      CALL xios_solve_inheritance() 
    13341244   END SUBROUTINE iom_set_grid_attr 
    … …  
    13721282      ni=nlei-nldi+1 ; nj=nlej-nldj+1 
    13731283 
    1374 #if ! defined key_xios2 
    1375      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    1376 #else 
    1377      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
    1378 #endif      
     1284      CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    13791285      CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    13801286      CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)),   & 
    … …  
    13901296         END SELECT 
    13911297         ! 
    1392 #if ! defined key_xios2 
    13931298         CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni,nj    /)) /= 0. ) 
    1394 #else 
    1395          CALL iom_set_domain_attr( "grid_"//cdgrd       , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj    /)) /= 0. ) 
    1396 #endif   
    13971299         CALL iom_set_grid_attr  ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,jpk/)) /= 0. ) 
    13981300      ENDIF 
    … …  
    15281430      ALLOCATE( zlon(ni*nj) )       ;       zlon(:) = 0. 
    15291431 
    1530       CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    1531 #if ! defined key_xios2 
    15321432      CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-1, jbegin=njmpp+nldj-1, ni=ni, nj=nj) 
    15331433      CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    … …  
    15351435         &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    15361436      ! 
     1437      CALL dom_ngb( 180., 90., ix, iy, 'T' ) !  i-line that passes near the North Pole : Reference latitude (used in plots) 
    15371438      CALL iom_set_domain_attr ('ptr', zoom_ibegin=ix, zoom_nj=jpjglo) 
    1538 #else 
    1539 ! Pas teste : attention aux indices ! 
    1540       CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) 
    1541       CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) 
    1542       CALL iom_set_domain_attr("gznl", lonvalue = zlon,   & 
    1543          &                             latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /)))   
    1544        CALL iom_set_zoom_domain_attr ("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) 
    1545 #endif 
    1546  
    15471439      CALL iom_update_file_name('ptr') 
    15481440      ! 
    … …  
    15581450      REAL(wp), DIMENSION(1)   ::   zz = 1. 
    15591451      !!---------------------------------------------------------------------- 
    1560 #if ! defined key_xios2 
    15611452      CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea, jbegin=1, ni=1, nj=1) 
    1562 #else 
    1563       CALL iom_set_domain_attr('scalarpoint', ni_glo=jpnij, nj_glo=1, ibegin=narea-1, jbegin=0, ni=1, nj=1) 
    1564 #endif 
    15651453      CALL iom_set_domain_attr('scalarpoint', data_dim=2, data_ibegin = 1, data_ni = 1, data_jbegin = 1, data_nj = 1) 
    15661454       
    15671455      zz=REAL(narea,wp) 
    15681456      CALL iom_set_domain_attr('scalarpoint', lonvalue=zz, latvalue=zz) 
    1569        
     1457 
    15701458   END SUBROUTINE set_scalar 
    15711459 
    … …  
    15911479      REAL(wp)        ,DIMENSION( 3) ::   zlonpira                 ! longitudes of pirata moorings 
    15921480      REAL(wp)        ,DIMENSION( 9) ::   zlatpira                 ! latitudes  of pirata moorings 
    1593 #if  defined key_xios2 
    1594       TYPE(xios_duration)            ::   f_op, f_of 
    1595 #endif 
    1596   
    15971481      !!---------------------------------------------------------------------- 
    15981482      !  
    15991483      ! frequency of the call of iom_put (attribut: freq_op) 
    1600 #if ! defined key_xios2 
    1601       WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op=cl1//'ts', freq_offset='0ts') 
    1602       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op=cl1//'ts', freq_offset='0ts') 
    1603       WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op=cl1//'ts', freq_offset='0ts') 
    1604       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
    1605       WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op=cl1//'ts', freq_offset='0ts') 
    1606 #else 
    1607       f_op%timestep = 1        ;  f_of%timestep = 0  ; CALL iom_set_field_attr('field_definition', freq_op=f_op, freq_offset=f_of) 
    1608       f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC'             , freq_op=f_op, freq_offset=f_of) 
    1609       f_op%timestep = nn_fsbc  ;  f_of%timestep = 0  ; CALL iom_set_field_attr('SBC_scalar'      , freq_op=f_op, freq_offset=f_of) 
    1610       f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('ptrc_T'          , freq_op=f_op, freq_offset=f_of) 
    1611       f_op%timestep = nn_dttrc ;  f_of%timestep = 0  ; CALL iom_set_field_attr('diad_T'          , freq_op=f_op, freq_offset=f_of) 
    1612 #endif 
     1484      WRITE(cl1,'(i1)')        1   ;   CALL iom_set_field_attr('field_definition', freq_op = cl1//'ts', freq_offset='0ts') 
     1485      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC'             , freq_op = cl1//'ts', freq_offset='0ts') 
     1486      WRITE(cl1,'(i1)')  nn_fsbc   ;   CALL iom_set_field_attr('SBC_scalar'      , freq_op = cl1//'ts', freq_offset='0ts') 
     1487      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('ptrc_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
     1488      WRITE(cl1,'(i1)') nn_dttrc   ;   CALL iom_set_field_attr('diad_T'          , freq_op = cl1//'ts', freq_offset='0ts') 
    16131489        
    16141490      ! output file names (attribut: name) 
    … …  
    16321508         ! Equatorial section (attributs: jbegin, ni, name_suffix) 
    16331509         CALL dom_ngb( 0., 0., ix, iy, cl1 ) 
    1634 #if ! defined key_xios2 
    16351510         CALL iom_set_domain_attr ('Eq'//cl1, zoom_jbegin=iy, zoom_ni=jpiglo) 
    1636 #else 
    1637          CALL iom_set_zoom_domain_attr ('Eq'//cl1, jbegin=iy-1, ni=jpiglo) 
    1638 #endif 
    16391511         CALL iom_get_file_attr   ('Eq'//cl1, name_suffix = clsuff             ) 
    16401512         CALL iom_set_file_attr   ('Eq'//cl1, name_suffix = TRIM(clsuff)//'_Eq') 
    … …  
    17161588               ENDIF 
    17171589               clname = TRIM(ADJUSTL(clat))//TRIM(ADJUSTL(clon)) 
    1718 #if ! defined key_xios2 
    17191590               CALL iom_set_domain_attr (TRIM(clname)//cl1, zoom_ibegin= ix, zoom_jbegin= iy) 
    1720 #else 
    1721                CALL iom_set_zoom_domain_attr  (TRIM(clname)//cl1, ibegin= ix-1, jbegin= iy-1) 
    1722 #endif 
    17231591               CALL iom_get_file_attr   (TRIM(clname)//cl1, name_suffix = clsuff                         ) 
    17241592               CALL iom_set_file_attr   (TRIM(clname)//cl1, name_suffix = TRIM(clsuff)//'_'//TRIM(clname)) 
    … …  
    17491617      REAL(wp)           ::   zsec 
    17501618      LOGICAL            ::   llexist 
    1751 #if  defined key_xios2 
    1752       TYPE(xios_duration)   ::   output_freq  
    1753 #endif       
    1754       !!---------------------------------------------------------------------- 
    1755  
     1619      !!---------------------------------------------------------------------- 
    17561620 
    17571621      DO jn = 1,2 
    1758 #if ! defined key_xios2 
     1622 
    17591623         IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = clfreq ) 
    1760 #else 
    1761          output_freq = xios_duration(0,0,0,0,0,0) 
    1762          IF( jn == 1 )   CALL iom_get_file_attr( cdid, name        = clname, output_freq = output_freq ) 
    1763 #endif 
    17641624         IF( jn == 2 )   CALL iom_get_file_attr( cdid, name_suffix = clname ) 
    17651625 
    … …  
    17721632            END DO 
    17731633 
    1774 #if ! defined key_xios2 
    17751634            idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    17761635            DO WHILE ( idx /= 0 )  
    … …  
    17851644               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    17861645            END DO 
    1787 #else 
    1788             idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    1789             DO WHILE ( idx /= 0 )  
    1790               IF ( output_freq%timestep /= 0) THEN 
    1791                   WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts'  
    1792                   itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
    1793               ELSE IF ( output_freq%hour /= 0 ) THEN 
    1794                   WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h'  
    1795                   itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
    1796               ELSE IF ( output_freq%day /= 0 ) THEN 
    1797                   WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d'  
    1798                   itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
    1799               ELSE IF ( output_freq%month /= 0 ) THEN    
    1800                   WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m'  
    1801                   itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
    1802               ELSE IF ( output_freq%year /= 0 ) THEN    
    1803                   WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y'  
    1804                   itrlen = LEN_TRIM(ADJUSTL(clfreq)) 
    1805               ELSE 
    1806                   CALL ctl_stop('error in the name of file id '//TRIM(cdid),   & 
    1807                      & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) 
    1808               ENDIF 
    1809               clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) 
    1810               idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') 
    1811             END DO 
    1812 #endif 
     1646 
    18131647            idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') 
    18141648            DO WHILE ( idx /= 0 )  
    … …  
    18391673            END DO 
    18401674 
    1841             IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' )   clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) 
    18421675            IF( jn == 1 )   CALL iom_set_file_attr( cdid, name        = clname ) 
    18431676            IF( jn == 2 )   CALL iom_set_file_attr( cdid, name_suffix = clname ) 
    … …  
    18871720      ENDIF 
    18881721       
    1889 !$AGRIF_DO_NOT_TREAT       
    1890 ! Should be fixed in the conv 
    18911722      IF( llfull ) THEN  
    18921723         clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" 
    … …  
    18991730         WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday                          ! date of the end of run 
    19001731      ENDIF 
    1901 !$AGRIF_END_DO_NOT_TREAT       
    19021732 
    19031733   END FUNCTION iom_sdate 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90

    r6617 r6625  
    298298      ENDIF 
    299299 
    300 #if defined key_agrif 
    301       IF (Agrif_Root()) THEN 
    302          CALL Agrif_MPI_Init(mpi_comm_opa) 
    303       ELSE 
    304          CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 
    305       ENDIF 
    306 #endif 
    307  
    308300      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    309301      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90

    r6617 r6625  
    201201       
    202202#endif 
     203      IF(lwp) THEN 
     204         WRITE(numout,*) 
     205         WRITE(numout,*) '           defines mpp subdomains' 
     206         WRITE(numout,*) '           ----------------------' 
     207         WRITE(numout,*) '           iresti=',iresti,' irestj=',irestj 
     208         WRITE(numout,*) '           jpni  =',jpni  ,' jpnj  =',jpnj 
     209         ifreq = 4 
     210         il1   = 1 
     211         DO jn = 1, (jpni-1)/ifreq+1 
     212            il2 = MIN( jpni, il1+ifreq-1 ) 
     213            WRITE(numout,*) 
     214            WRITE(numout,9200) ('***',ji = il1,il2-1) 
     215            DO jj = jpnj, 1, -1 
     216               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     217               WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
     218               WRITE(numout,9203) ('   ',ji = il1,il2-1) 
     219               WRITE(numout,9200) ('***',ji = il1,il2-1) 
     220            END DO 
     221            WRITE(numout,9201) (ji,ji = il1,il2) 
     222            il1 = il1+ifreq 
     223         END DO 
     224 9200    FORMAT('     ***',20('*************',a3)) 
     225 9203    FORMAT('     *     ',20('         *   ',a3)) 
     226 9201    FORMAT('        ',20('   ',i3,'          ')) 
     227 9202    FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
     228      ENDIF 
     229 
     230      zidom = nreci 
     231      DO ji = 1, jpni 
     232         zidom = zidom + ilcit(ji,1) - nreci 
     233      END DO 
     234      IF(lwp) WRITE(numout,*) 
     235      IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo 
     236       
     237      zjdom = nrecj 
     238      DO jj = 1, jpnj 
     239         zjdom = zjdom + ilcjt(1,jj) - nrecj 
     240      END DO 
     241      IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo 
     242      IF(lwp) WRITE(numout,*) 
     243       
    203244 
    204245      !  2. Index arrays for subdomains 
    … …  
    263304         nlejt(jn) = nlej 
    264305      END DO 
    265  
    266       ! 4. Subdomain print 
    267       ! ------------------ 
    268        
    269       IF(lwp) WRITE(numout,*) 
    270       IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 
    271       IF(lwp) WRITE(numout,*) ' ~~~~~~  ----------------------' 
    272       IF(lwp) WRITE(numout,*) 
    273       IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 
    274       IF(lwp) WRITE(numout,*) 
    275       IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 
    276       zidom = nreci 
    277       DO ji = 1, jpni 
    278          zidom = zidom + ilcit(ji,1) - nreci 
    279       END DO 
    280       IF(lwp) WRITE(numout,*) 
    281       IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 
    282  
    283       zjdom = nrecj 
    284       DO jj = 1, jpnj 
    285          zjdom = zjdom + ilcjt(1,jj) - nrecj 
    286       END DO 
    287       IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 
    288       IF(lwp) WRITE(numout,*) 
    289  
    290       IF(lwp) THEN 
    291          ifreq = 4 
    292          il1   = 1 
    293          DO jn = 1, (jpni-1)/ifreq+1 
    294             il2 = MIN( jpni, il1+ifreq-1 ) 
    295             WRITE(numout,*) 
    296             WRITE(numout,9200) ('***',ji = il1,il2-1) 
    297             DO jj = jpnj, 1, -1 
    298                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    299                WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 
    300                WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 
    301                WRITE(numout,9203) ('   ',ji = il1,il2-1) 
    302                WRITE(numout,9200) ('***',ji = il1,il2-1) 
    303             END DO 
    304             WRITE(numout,9201) (ji,ji = il1,il2) 
    305             il1 = il1+ifreq 
    306          END DO 
    307  9200     FORMAT('     ***',20('*************',a3)) 
    308  9203     FORMAT('     *     ',20('         *   ',a3)) 
    309  9201     FORMAT('        ',20('   ',i3,'          ')) 
    310  9202     FORMAT(' ',i3,' *  ',20(i3,'  x',i3,'   *   ')) 
    311  9204     FORMAT('     *  ',20('      ',i3,'   *   ')) 
    312       ENDIF 
    313  
    314       ! 5. From global to local 
     306       
     307 
     308      ! 4. From global to local 
    315309      ! ----------------------- 
    316310 
    … …  
    319313 
    320314 
    321       ! 6. Subdomain neighbours 
     315      ! 5. Subdomain neighbours 
    322316      ! ---------------------- 
    323317 
    … …  
    442436         WRITE(numout,*) ' nimpp  = ', nimpp 
    443437         WRITE(numout,*) ' njmpp  = ', njmpp 
    444          WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
    445          WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
    446          WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
    447          WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
    448          WRITE(numout,*) 
     438         WRITE(numout,*) ' nbse   = ', nbse  , ' npse   = ', npse 
     439         WRITE(numout,*) ' nbsw   = ', nbsw  , ' npsw   = ', npsw 
     440         WRITE(numout,*) ' nbne   = ', nbne  , ' npne   = ', npne 
     441         WRITE(numout,*) ' nbnw   = ', nbnw  , ' npnw   = ', npnw 
    449442      ENDIF 
    450443 
    … …  
    453446      ! Prepare mpp north fold 
    454447 
    455       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     448      IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    456449         CALL mpp_ini_north 
    457          IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 
    458       ENDIF 
     450      END IF 
    459451 
    460452      ! Prepare NetCDF output file (if necessary) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90

    r6617 r6625  
    318318         ENDIF 
    319319 
    320          ! Check wet points over the entire domain to preserve the MPI communication stencil 
    321320         isurf = 0 
    322          DO jj = 1, ilj 
    323             DO  ji = 1, ili 
     321         DO jj = 1+jprecj, ilj-jprecj 
     322            DO  ji = 1+jpreci, ili-jpreci 
    324323               IF( imask(ji+iimppt(ii,ij)-1, jj+ijmppt(ii,ij)-1) == 1) isurf = isurf+1 
    325324            END DO 
    326325         END DO 
    327  
    328326         IF(isurf /= 0) THEN 
    329327            icont = icont + 1 
    … …  
    335333 
    336334      nfipproc(:,:) = ipproc(:,:) 
     335 
    337336 
    338337      ! Control 
    … …  
    442441      ii = iin(narea) 
    443442      ij = ijn(narea) 
    444  
    445       ! set default neighbours 
    446       noso = ioso(ii,ij) 
    447       nowe = iowe(ii,ij) 
    448       noea = ioea(ii,ij) 
    449       nono = iono(ii,ij)  
    450       npse = iose(ii,ij) 
    451       npsw = iosw(ii,ij) 
    452       npne = ione(ii,ij) 
    453       npnw = ionw(ii,ij) 
    454  
    455       ! check neighbours location 
    456443      IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN  
    457444         iiso = 1 + MOD(ioso(ii,ij),jpni) 
    … …  
    524511      IF (lwp) THEN 
    525512         CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 
    526          WRITE(inum,'(a)') '   jpnij     jpi     jpj     jpk  jpiglo  jpjglo' 
    527513         WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 
    528514         WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' 
    … …  
    537523      END IF 
    538524 
     525      IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2:  error on cyclicity' ) 
     526 
     527      ! Prepare mpp north fold 
     528 
     529      IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
     530         CALL mpp_ini_north 
     531         IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
     532      ENDIF 
     533 
    539534      ! Defined npolj, either 0, 3 , 4 , 5 , 6 
    540535      ! In this case the important thing is that npolj /= 0 
    … …  
    553548      ENDIF 
    554549 
    555       ! Periodicity : no corner if nbondi = 2 and nperio != 1 
    556  
    557       IF(lwp) THEN 
    558          WRITE(numout,*) ' nproc  = ', nproc 
    559          WRITE(numout,*) ' nowe   = ', nowe  , ' noea   =  ', noea 
    560          WRITE(numout,*) ' nono   = ', nono  , ' noso   =  ', noso 
    561          WRITE(numout,*) ' nbondi = ', nbondi 
    562          WRITE(numout,*) ' nbondj = ', nbondj 
    563          WRITE(numout,*) ' npolj  = ', npolj 
    564          WRITE(numout,*) ' nperio = ', nperio 
    565          WRITE(numout,*) ' nlci   = ', nlci 
    566          WRITE(numout,*) ' nlcj   = ', nlcj 
    567          WRITE(numout,*) ' nimpp  = ', nimpp 
    568          WRITE(numout,*) ' njmpp  = ', njmpp 
    569          WRITE(numout,*) ' nreci  = ', nreci  , ' npse   = ', npse 
    570          WRITE(numout,*) ' nrecj  = ', nrecj  , ' npsw   = ', npsw 
    571          WRITE(numout,*) ' jpreci = ', jpreci , ' npne   = ', npne 
    572          WRITE(numout,*) ' jprecj = ', jprecj , ' npnw   = ', npnw 
    573          WRITE(numout,*) 
    574       ENDIF 
    575  
    576       IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 
    577  
    578       ! Prepare mpp north fold 
    579  
    580       IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 
    581          CALL mpp_ini_north 
    582          IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 
    583       ENDIF 
    584  
    585550      ! Prepare NetCDF output file (if necessary) 
    586551      CALL mpp_init_ioipsl 
    587552 
     553      ! Periodicity : no corner if nbondi = 2 and nperio != 1 
     554 
     555      IF(lwp) THEN 
     556         WRITE(numout,*) ' nproc=  ',nproc 
     557         WRITE(numout,*) ' nowe=   ',nowe 
     558         WRITE(numout,*) ' noea=   ',noea 
     559         WRITE(numout,*) ' nono=   ',nono 
     560         WRITE(numout,*) ' noso=   ',noso 
     561         WRITE(numout,*) ' nbondi= ',nbondi 
     562         WRITE(numout,*) ' nbondj= ',nbondj 
     563         WRITE(numout,*) ' npolj=  ',npolj 
     564         WRITE(numout,*) ' nperio= ',nperio 
     565         WRITE(numout,*) ' nlci=   ',nlci 
     566         WRITE(numout,*) ' nlcj=   ',nlcj 
     567         WRITE(numout,*) ' nimpp=  ',nimpp 
     568         WRITE(numout,*) ' njmpp=  ',njmpp 
     569         WRITE(numout,*) ' nbse=   ',nbse,' npse= ',npse 
     570         WRITE(numout,*) ' nbsw=   ',nbsw,' npsw= ',npsw 
     571         WRITE(numout,*) ' nbne=   ',nbne,' npne= ',npne 
     572         WRITE(numout,*) ' nbnw=   ',nbnw,' npnw= ',npnw 
     573      ENDIF 
    588574 
    589575   END SUBROUTINE mpp_init2 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LDF/ldfslp.F90

    r6617 r6625  
    188188            DO jj = 2, jpjm1 
    189189               DO ji = fs_2, fs_jpim1   ! vector opt. 
    190                zhmlpu(ji,jj) = ( MAX(hmlpt(ji,jj)  , hmlpt  (ji+1,jj  ), 5._wp)   & 
    191                   &            - MAX(risfdep(ji,jj), risfdep(ji+1,jj  )       )   ) 
    192                zhmlpv(ji,jj) = ( MAX(hmlpt  (ji,jj), hmlpt  (ji  ,jj+1), 5._wp)   & 
    193                   &            - MAX(risfdep(ji,jj), risfdep(ji  ,jj+1)       )   ) 
     190                  IF (miku(ji,jj) .GT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     191                  IF (miku(ji,jj) .LT. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji+1,jj  ),                   5._wp) 
     192                  IF (miku(ji,jj) .EQ. miku(ji+1,jj)) zhmlpu(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji+1,jj  ), 5._wp) 
     193                  IF (mikv(ji,jj) .GT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ),                   5._wp) 
     194                  IF (mikv(ji,jj) .LT. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj+1),                   5._wp) 
     195                  IF (mikv(ji,jj) .EQ. miku(ji,jj+1)) zhmlpv(ji,jj) = MAX(hmlpt(ji  ,jj  ), hmlpt(ji  ,jj+1), 5._wp) 
    194196               ENDDO 
    195197            ENDDO 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_oce.F90

    r6617 r6625  
    4141 
    4242   REAL(wp), PUBLIC ::   rldf                        !: multiplicative factor of diffusive coefficient 
    43    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   r_fact_lap 
    4443                                                     !: Needed to define the ratio between passive and active tracer diffusion coef.  
    4544 
    … …  
    9392      !!                 ***  FUNCTION ldftra_oce_alloc  *** 
    9493     !!---------------------------------------------------------------------- 
    95      INTEGER, DIMENSION(4) :: ierr 
     94     INTEGER, DIMENSION(3) :: ierr 
    9695     !!---------------------------------------------------------------------- 
    9796     ierr(:) = 0 
    … …  
    117116# endif 
    118117#endif 
    119       ALLOCATE( r_fact_lap(jpi,jpj,jpk), STAT=ierr(4) ) 
    120118      ldftra_oce_alloc = MAXVAL( ierr ) 
    121119      IF( ldftra_oce_alloc /= 0 )   CALL ctl_warn('ldftra_oce_alloc: failed to allocate arrays') 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/LDF/ldftra_substitute.h90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/albedo.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/fldread.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbc_ice.F90

    r6617 r6625  
    8080   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_oce       !: heat flux of precip and evap over ocean     [W/m2] 
    8181   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qemp_ice       !: heat flux of precip and evap over ice       [W/m2] 
    82    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   qevap_ice      !: heat flux of evap over ice                  [W/m2] 
    83    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: enthalpy of precip over ice                 [J/m3] 
     82   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   qprec_ice      !: heat flux of precip over ice                [J/m3] 
    8483   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   emp_oce        !: evap - precip over ocean                 [kg/m2/s] 
    8584#endif 
    … …  
    145144#endif 
    146145#if defined key_lim3 
    147          &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,   & 
    148          &      qemp_ice(jpi,jpj)     , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) ,   & 
    149          &      qns_oce (jpi,jpj)     , qsr_oce  (jpi,jpj)     , emp_oce (jpi,jpj)  ,   & 
     146         &      evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice(jpi,jpj) ,  & 
     147         &      qemp_ice(jpi,jpj)     , qemp_oce(jpi,jpj)      ,                       & 
     148         &      qns_oce (jpi,jpj)     , qsr_oce (jpi,jpj)      , emp_oce (jpi,jpj)  ,  & 
    150149#endif 
    151150         &      emp_ice(jpi,jpj)      ,  STAT= ierr(1) ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_clio.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcblk_core.F90

    r6617 r6625  
    403403         CALL iom_put( "qsr_oce" ,   qsr  )                 ! output downward solar heat over the ocean 
    404404         CALL iom_put( "qt_oce"  ,   qns+qsr )              ! output total downward heat over the ocean 
    405          tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac   ! output total precipitation [kg/m2/s] 
    406          sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac   ! output solid precipitation [kg/m2/s] 
    407          CALL iom_put( 'snowpre', sprecip * 86400. )        ! Snow 
    408          CALL iom_put( 'precip' , tprecip * 86400. )        ! Total precipitation 
    409405      ENDIF 
    410406      ! 
    … …  
    612608      ! --- evaporation --- ! 
    613609      z1_lsub = 1._wp / Lsub 
    614       evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_lsub    ! sublimation 
    615       devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_lsub    ! d(sublimation)/dT 
    616       zevap    (:,:)   = rn_efac * ( emp(:,:) + tprecip(:,:) )  ! evaporation over ocean 
     610      evap_ice (:,:,:) = qla_ice (:,:,:) * z1_lsub ! sublimation 
     611      devap_ice(:,:,:) = dqla_ice(:,:,:) * z1_lsub 
     612      zevap    (:,:)   = emp(:,:) + tprecip(:,:)   ! evaporation over ocean 
    617613 
    618614      ! --- evaporation minus precipitation --- ! 
    … …  
    637633      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    638634      qprec_ice(:,:) = rhosn * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0_snow ) - rt0 ) * cpic * tmask(:,:,1) - lfus ) 
    639  
    640       ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
    641       DO jl = 1, jpl 
    642          qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * cpic * tmask(:,:,1) ) 
    643                                    ! But we do not have Tice => consider it at 0°C => evap=0  
    644       END DO 
    645635 
    646636      CALL wrk_dealloc( jpi,jpj, zevap, zsnw )  

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbccpl.F90

    r6617 r6625  
    10291029         ssu_m(:,:) = frcv(jpr_ocx1)%z3(:,:,1) 
    10301030         ub (:,:,1) = ssu_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
    1031          un (:,:,1) = ssu_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10321031         CALL iom_put( 'ssu_m', ssu_m ) 
    10331032      ENDIF 
    … …  
    10351034         ssv_m(:,:) = frcv(jpr_ocy1)%z3(:,:,1) 
    10361035         vb (:,:,1) = ssv_m(:,:)                             ! will be used in sbcice_lim in the call of lim_sbc_tau 
    1037          vn (:,:,1) = ssv_m(:,:)                             ! will be used in sbc_cpl_snd if atmosphere coupling 
    10381036         CALL iom_put( 'ssv_m', ssv_m ) 
    10391037      ENDIF 
    … …  
    13781376      ! 
    13791377      INTEGER ::   jl         ! dummy loop index 
    1380       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 
    1382       REAL(wp), POINTER, DIMENSION(:,:  ) ::   zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice 
    1383       REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice 
     1378      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zcptn, ztmp, zicefr, zmsk 
     1379      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot 
     1380      REAL(wp), POINTER, DIMENSION(:,:,:) ::   zqns_ice, zqsr_ice, zdqns_ice 
     1381      REAL(wp), POINTER, DIMENSION(:,:  ) ::   zevap, zsnw, zqns_oce, zqsr_oce, zqprec_ice, zqemp_oce ! for LIM3 
    13841382      !!---------------------------------------------------------------------- 
    13851383      ! 
    13861384      IF( nn_timing == 1 )  CALL timing_start('sbc_cpl_ice_flx') 
    13871385      ! 
    1388       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 ) 
    1390       CALL wrk_alloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    1391       CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
     1386      CALL wrk_alloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1387      CALL wrk_alloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
    13921388 
    13931389      IF( ln_mixcpl )   zmsk(:,:) = 1. - xcplmask(:,:,0) 
    … …  
    14251421      END SELECT 
    14261422 
    1427 #if defined key_lim3 
    1428       ! zsnw = snow percentage over ice after wind blowing 
    1429       zsnw(:,:) = 0._wp 
    1430       CALL lim_thd_snwblow( p_frld, zsnw ) 
    1431        
    1432       ! --- evaporation (kg/m2/s) --- ! 
    1433       zevap_ice(:,:) = frcv(jpr_ievp)%z3(:,:,1) 
    1434       ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 
    1435       ! therefore, sublimation is not redistributed over the ice categories in case no subgrid scale fluxes are provided by atm. 
    1436       zdevap_ice(:,:) = 0._wp 
    1437        
    1438       ! --- evaporation minus precipitation corrected for the effect of wind blowing on snow --- ! 
    1439       zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) - zsprecip * (1._wp - zsnw) 
    1440       zemp_ice(:,:) = zemp_ice(:,:) + zsprecip * (1._wp - zsnw)           
    1441  
    1442       ! Sublimation over sea-ice (cell average) 
    1443       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', zevap_ice(:,:) * zicefr(:,:) ) 
    1444       ! runoffs and calving (put in emp_tot) 
    1445       IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    1446       IF( srcv(jpr_cal)%laction ) THEN  
    1447          zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) 
    1448          CALL iom_put( 'calving_cea', frcv(jpr_cal)%z3(:,:,1) ) 
    1449       ENDIF 
    1450  
    1451       IF( ln_mixcpl ) THEN 
    1452          emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) 
    1453          emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) 
    1454          emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) 
    1455          sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) 
    1456          tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) 
    1457          DO jl=1,jpl 
    1458             evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:) * zmsk(:,:) 
    1459             devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) 
    1460          ENDDO 
    1461       ELSE 
    1462          emp_tot(:,:) =         zemp_tot(:,:) 
    1463          emp_ice(:,:) =         zemp_ice(:,:) 
    1464          emp_oce(:,:) =         zemp_oce(:,:)      
    1465          sprecip(:,:) =         zsprecip(:,:) 
    1466          tprecip(:,:) =         ztprecip(:,:) 
    1467          DO jl=1,jpl 
    1468             evap_ice (:,:,jl) = zevap_ice (:,:) 
    1469             devap_ice(:,:,jl) = zdevap_ice(:,:) 
    1470          ENDDO 
    1471       ENDIF 
    1472  
    1473                                      CALL iom_put( 'snowpre'    , sprecip                         )  ! Snow 
    1474       IF( iom_use('snow_ao_cea') )   CALL iom_put( 'snow_ao_cea', sprecip(:,:) * ( 1._wp - zsnw ) )  ! Snow over ice-free ocean  (cell average) 
    1475       IF( iom_use('snow_ai_cea') )   CALL iom_put( 'snow_ai_cea', sprecip(:,:) *           zsnw   )  ! Snow over sea-ice         (cell average)     
    1476 #else 
    1477       ! Sublimation over sea-ice (cell average) 
    1478       IF( iom_use('subl_ai_cea') )  CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) ) 
    1479       ! runoffs and calving (put in emp_tot) 
     1423      IF( iom_use('subl_ai_cea') )   & 
     1424         CALL iom_put( 'subl_ai_cea', frcv(jpr_ievp)%z3(:,:,1) * zicefr(:,:) )   ! Sublimation over sea-ice         (cell average) 
     1425      !    
     1426      !                                                           ! runoffs and calving (put in emp_tot) 
    14801427      IF( srcv(jpr_rnf)%laction )   rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) 
    14811428      IF( srcv(jpr_cal)%laction ) THEN  
    … …  
    15011448      IF( iom_use('snow_ai_cea') )   & 
    15021449         CALL iom_put( 'snow_ai_cea', sprecip(:,:) * zicefr(:,:)             )   ! Snow        over sea-ice         (cell average) 
    1503 #endif 
    15041450 
    15051451      !                                                      ! ========================= ! 
    … …  
    15571503      IF( iom_use('hflx_snow_cea') )    CALL iom_put( 'hflx_snow_cea', ztmp + sprecip(:,:) * zcptn(:,:) )   ! heat flux from snow (cell average) 
    15581504 
    1559 #if defined key_lim3       
     1505#if defined key_lim3 
     1506      CALL wrk_alloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
     1507 
    15601508      ! --- evaporation --- ! 
     1509      ! clem: evap_ice is set to 0 for LIM3 since we still do not know what to do with sublimation 
     1510      ! the problem is: the atm. imposes both mass evaporation and heat removed from the snow/ice 
     1511      !                 but it is incoherent WITH the ice model   
     1512      DO jl=1,jpl 
     1513         evap_ice(:,:,jl) = 0._wp  ! should be: frcv(jpr_ievp)%z3(:,:,1) 
     1514      ENDDO 
    15611515      zevap(:,:) = zemp_tot(:,:) + ztprecip(:,:) ! evaporation over ocean 
     1516 
     1517      ! --- evaporation minus precipitation --- ! 
     1518      emp_oce(:,:) = emp_tot(:,:) - emp_ice(:,:) 
    15621519 
    15631520      ! --- non solar flux over ocean --- ! 
    … …  
    15661523      WHERE( p_frld /= 0._wp )  zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / p_frld(:,:) 
    15671524 
    1568       ! --- heat flux associated with emp (W/m2) --- ! 
     1525      ! --- heat flux associated with emp --- ! 
     1526      zsnw(:,:) = 0._wp 
     1527      CALL lim_thd_snwblow( p_frld, zsnw )  ! snow distribution over ice after wind blowing 
    15691528      zqemp_oce(:,:) = -      zevap(:,:)                   * p_frld(:,:)      *   zcptn(:,:)   &      ! evap 
    15701529         &             + ( ztprecip(:,:) - zsprecip(:,:) )                    *   zcptn(:,:)   &      ! liquid precip 
    15711530         &             +   zsprecip(:,:)                   * ( 1._wp - zsnw ) * ( zcptn(:,:) - lfus ) ! solid precip over ocean 
    1572 !      zqemp_ice(:,:) = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
    1573 !         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
    1574       zqemp_ice(:,:) =      zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice (only) 
    1575                                                                                                        ! qevap_ice=0 since we consider Tice=0°C 
    1576        
     1531      qemp_ice(:,:)  = -   frcv(jpr_ievp)%z3(:,:,1)        * zicefr(:,:)      *   zcptn(:,:)   &      ! ice evap 
     1532         &             +   zsprecip(:,:)                   * zsnw             * ( zcptn(:,:) - lfus ) ! solid precip over ice 
     1533 
    15771534      ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! 
    15781535      zqprec_ice(:,:) = rhosn * ( zcptn(:,:) - lfus ) 
    15791536 
    1580       ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! 
    1581       DO jl = 1, jpl 
    1582          zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * cpic ) but we do not have Tice, so we consider Tice=0°C 
    1583       END DO 
    1584  
    1585       ! --- total non solar flux (including evap/precip) --- ! 
    1586       zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) 
     1537      ! --- total non solar flux --- ! 
     1538      zqns_tot(:,:) = zqns_tot(:,:) + qemp_ice(:,:) + zqemp_oce(:,:) 
    15871539 
    15881540      ! --- in case both coupled/forced are active, we must mix values --- !  
    … …  
    15911543         qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) 
    15921544         DO jl=1,jpl 
    1593             qns_ice  (:,:,jl) = qns_ice  (:,:,jl) * xcplmask(:,:,0) +  zqns_ice  (:,:,jl)* zmsk(:,:) 
    1594             qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) +  zqevap_ice(:,:,jl)* zmsk(:,:) 
     1545            qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) +  zqns_ice(:,:,jl)* zmsk(:,:) 
    15951546         ENDDO 
    15961547         qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) 
    15971548         qemp_oce (:,:) =  qemp_oce(:,:) * xcplmask(:,:,0) +  zqemp_oce(:,:)* zmsk(:,:) 
    1598          qemp_ice (:,:) =  qemp_ice(:,:) * xcplmask(:,:,0) +  zqemp_ice(:,:)* zmsk(:,:) 
     1549!!clem         evap_ice(:,:) = evap_ice(:,:) * xcplmask(:,:,0) 
    15991550      ELSE 
    16001551         qns_tot  (:,:  ) = zqns_tot  (:,:  ) 
    16011552         qns_oce  (:,:  ) = zqns_oce  (:,:  ) 
    16021553         qns_ice  (:,:,:) = zqns_ice  (:,:,:) 
    1603          qevap_ice(:,:,:) = zqevap_ice(:,:,:) 
    1604          qprec_ice(:,:  ) = zqprec_ice(:,:  ) 
    1605          qemp_oce (:,:  ) = zqemp_oce (:,:  ) 
    1606          qemp_ice (:,:  ) = zqemp_ice (:,:  ) 
    1607       ENDIF 
     1554         qprec_ice(:,:)   = zqprec_ice(:,:) 
     1555         qemp_oce (:,:)   = zqemp_oce (:,:) 
     1556      ENDIF 
     1557 
     1558      CALL wrk_dealloc( jpi,jpj, zevap, zsnw, zqns_oce, zqprec_ice, zqemp_oce )  
    16081559#else 
     1560 
    16091561      ! clem: this formulation is certainly wrong... but better than it was... 
    16101562      zqns_tot(:,:) = zqns_tot(:,:)                       &            ! zqns_tot update over free ocean with: 
    … …  
    16231575         qns_ice(:,:,:) = zqns_ice(:,:,:) 
    16241576      ENDIF 
     1577 
    16251578#endif 
    16261579 
    … …  
    16731626 
    16741627#if defined key_lim3 
     1628      CALL wrk_alloc( jpi,jpj, zqsr_oce )  
    16751629      ! --- solar flux over ocean --- ! 
    16761630      !         note: p_frld cannot be = 0 since we limit the ice concentration to amax 
    … …  
    16801634      IF( ln_mixcpl ) THEN   ;   qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) +  zqsr_oce(:,:)* zmsk(:,:) 
    16811635      ELSE                   ;   qsr_oce(:,:) = zqsr_oce(:,:)   ;   ENDIF 
     1636 
     1637      CALL wrk_dealloc( jpi,jpj, zqsr_oce )  
    16821638#endif 
    16831639 
    … …  
    17301686      fr2_i0(:,:) = ( 0.82 * ( 1.0 - cldf_ice ) + 0.65 * cldf_ice ) 
    17311687 
    1732       CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zsnw ) 
    1733       CALL wrk_dealloc( jpi,jpj,     zemp_tot, zemp_ice, zemp_oce, ztprecip, zsprecip, zevap, zevap_ice, zdevap_ice ) 
    1734       CALL wrk_dealloc( jpi,jpj,     zqns_tot, zqns_oce, zqsr_tot, zqsr_oce, zqprec_ice, zqemp_oce, zqemp_ice ) 
    1735       CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice, zqevap_ice ) 
     1688      CALL wrk_dealloc( jpi,jpj,     zcptn, ztmp, zicefr, zmsk, zemp_tot, zemp_ice, zsprecip, ztprecip, zqns_tot, zqsr_tot ) 
     1689      CALL wrk_dealloc( jpi,jpj,jpl, zqns_ice, zqsr_ice, zdqns_ice ) 
    17361690      ! 
    17371691      IF( nn_timing == 1 )  CALL timing_stop('sbc_cpl_ice_flx') 
    … …  
    17891743                     ztmp3(:,:,1) = SUM( tn_ice * a_i, dim=3 ) / SUM( a_i, dim=3 ) 
    17901744                  ELSEWHERE 
    1791                      ztmp3(:,:,1) = rt0 
     1745                     ztmp3(:,:,1) = rt0 ! TODO: Is freezing point a good default? (Maybe SST is better?) 
    17921746                  END WHERE 
    17931747               CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_temp%clcat' ) 
    … …  
    18201774      !                                                      ! ------------------------- ! 
    18211775      IF( ssnd(jps_albice)%laction ) THEN                         ! ice  
    1822           SELECT CASE( sn_snd_alb%cldes ) 
    1823           CASE( 'ice' ) 
    1824              SELECT CASE( sn_snd_alb%clcat ) 
    1825              CASE( 'yes' )    
    1826                 ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
    1827              CASE( 'no' ) 
    1828                 WHERE( SUM( a_i, dim=3 ) /= 0. ) 
    1829                    ztmp1(:,:) = SUM( alb_ice (:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) / SUM( a_i(:,:,1:jpl), dim=3 ) 
    1830                 ELSEWHERE 
    1831                    ztmp1(:,:) = albedo_oce_mix(:,:) 
    1832                 END WHERE 
    1833              CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%clcat' ) 
    1834              END SELECT 
    1835           CASE( 'weighted ice' )   ; 
    1836              SELECT CASE( sn_snd_alb%clcat ) 
    1837              CASE( 'yes' )    
    1838                 ztmp3(:,:,1:jpl) =  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
    1839              CASE( 'no' ) 
    1840                 WHERE( fr_i (:,:) > 0. ) 
    1841                    ztmp1(:,:) = SUM (  alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl), dim=3 ) 
    1842                 ELSEWHERE 
    1843                    ztmp1(:,:) = 0. 
    1844                 END WHERE 
    1845              CASE default   ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ice%clcat' ) 
    1846              END SELECT 
    1847           CASE default      ;   CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
     1776         SELECT CASE( sn_snd_alb%cldes ) 
     1777         CASE( 'ice'          )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) 
     1778         CASE( 'weighted ice' )   ; ztmp3(:,:,1:jpl) = alb_ice(:,:,1:jpl) * a_i(:,:,1:jpl) 
     1779         CASE default             ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_alb%cldes' ) 
    18481780         END SELECT 
    1849  
    1850          SELECT CASE( sn_snd_alb%clcat ) 
    1851             CASE( 'yes' )    
    1852                CALL cpl_snd( jps_albice, isec, ztmp3, info )      !-> MV this has never been checked in coupled mode 
    1853             CASE( 'no'  )    
    1854                CALL cpl_snd( jps_albice, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info )  
    1855          END SELECT 
    1856       ENDIF 
    1857  
     1781         CALL cpl_snd( jps_albice, isec, ztmp3, info ) 
     1782      ENDIF 
    18581783      IF( ssnd(jps_albmix)%laction ) THEN                         ! mixed ice-ocean 
    18591784         ztmp1(:,:) = albedo_oce_mix(:,:) * zfr_l(:,:) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcfwb.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_if.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim.F90

    r6617 r6625  
    110110      INTEGER  ::   jl                 ! dummy loop index 
    111111      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_os, zalb_cs  ! ice albedo under overcast/clear sky 
     112      REAL(wp), POINTER, DIMENSION(:,:,:)   ::   zalb_ice          ! mean ice albedo (for coupled) 
    112113      REAL(wp), POINTER, DIMENSION(:,:  )   ::   zutau_ice, zvtau_ice  
    113114      !!---------------------------------------------------------------------- 
    … …  
    125126          
    126127         ! masked sea surface freezing temperature [Kelvin] (set to rt0 over land) 
    127          CALL eos_fzp( sss_m(:,:) , t_bo(:,:) ) 
    128          t_bo(:,:) = ( t_bo(:,:) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) ) 
    129            
     128         t_bo(:,:) = ( eos_fzp( sss_m ) + rt0 ) * tmask(:,:,1) + rt0 * ( 1._wp - tmask(:,:,1) )   
     129          
    130130         ! Mask sea ice surface temperature (set to rt0 over land) 
    131131         DO jl = 1, jpl 
    … …  
    196196         ! fr1_i0  , fr2_i0   : 1sr & 2nd fraction of qsr penetration in ice             [%] 
    197197         !---------------------------------------------------------------------------------------- 
    198          CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
     198         CALL wrk_alloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    199199         CALL albedo_ice( t_su, ht_i, ht_s, zalb_cs, zalb_os ) ! cloud-sky and overcast-sky ice albedos 
    200200 
    … …  
    202202         CASE( jp_clio )                                       ! CLIO bulk formulation 
    203203            ! In CLIO the cloud fraction is read in the climatology and the all-sky albedo  
    204             ! (alb_ice) is computed within the bulk routine 
    205                                  CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, alb_ice ) 
    206             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
    207             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     204            ! (zalb_ice) is computed within the bulk routine 
     205            CALL blk_ice_clio_flx( t_su, zalb_cs, zalb_os, zalb_ice ) 
     206            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     207            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    208208         CASE( jp_core )                                       ! CORE bulk formulation 
    209209            ! albedo depends on cloud fraction because of non-linear spectral effects 
    210             alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    211                                  CALL blk_ice_core_flx( t_su, alb_ice ) 
    212             IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
    213             IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     210            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     211            CALL blk_ice_core_flx( t_su, zalb_ice ) 
     212            IF( ln_mixcpl      ) CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     213            IF( nn_limflx /= 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    214214         CASE ( jp_purecpl ) 
    215215            ! albedo depends on cloud fraction because of non-linear spectral effects 
    216             alb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
    217                                  CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=alb_ice, psst=sst_m, pist=t_su ) 
    218             IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, alb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
     216            zalb_ice(:,:,:) = ( 1. - cldf_ice ) * zalb_cs(:,:,:) + cldf_ice * zalb_os(:,:,:) 
     217                                 CALL sbc_cpl_ice_flx( p_frld=pfrld, palbi=zalb_ice, psst=sst_m, pist=t_su ) 
     218            ! clem: evap_ice is forced to 0 in coupled mode for now  
     219            !       but it needs to be changed (along with modif in limthd_dh) once heat flux from evap will be avail. from atm. models 
     220            evap_ice  (:,:,:) = 0._wp   ;   devap_ice (:,:,:) = 0._wp 
     221            IF( nn_limflx == 2 ) CALL ice_lim_flx( t_su, zalb_ice, qns_ice, qsr_ice, dqns_ice, evap_ice, devap_ice, nn_limflx ) 
    219222         END SELECT 
    220          CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs ) 
     223         CALL wrk_dealloc( jpi,jpj,jpl, zalb_os, zalb_cs, zalb_ice ) 
    221224 
    222225         !----------------------------! 
    … …  
    261264      !!---------------------------------------------------------------------- 
    262265      INTEGER :: ierr 
    263       INTEGER :: ji, jj 
    264266      !!---------------------------------------------------------------------- 
    265267      IF(lwp) WRITE(numout,*) 
    … …  
    318320      tn_ice(:,:,:) = t_su(:,:,:)       ! initialisation of surface temp for coupled simu 
    319321      ! 
    320       DO jj = 1, jpj 
    321          DO ji = 1, jpi 
    322             IF( gphit(ji,jj) > 0._wp ) THEN  ;  rn_amax_2d(ji,jj) = rn_amax_n  ! NH 
    323             ELSE                             ;  rn_amax_2d(ji,jj) = rn_amax_s  ! SH 
    324             ENDIF 
    325         ENDDO 
    326       ENDDO  
    327       ! 
    328322      nstart = numit  + nn_fsbc       
    329323      nitrun = nitend - nit000 + 1  
    … …  
    348342      INTEGER  ::   ios                 ! Local integer output status for namelist read 
    349343      NAMELIST/namicerun/ jpl, nlay_i, nlay_s, cn_icerst_in, cn_icerst_indir, cn_icerst_out, cn_icerst_outdir,  & 
    350          &                ln_limdyn, rn_amax_n, rn_amax_s, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
     344         &                ln_limdyn, rn_amax, ln_limdiahsb, ln_limdiaout, ln_icectl, iiceprt, jiceprt   
    351345      !!------------------------------------------------------------------- 
    352346      !                     
    … …  
    369363         WRITE(numout,*) '   number of snow layers                                   = ', nlay_s 
    370364         WRITE(numout,*) '   switch for ice dynamics (1) or not (0)      ln_limdyn   = ', ln_limdyn 
    371          WRITE(numout,*) '   maximum ice concentration for NH                        = ', rn_amax_n  
    372          WRITE(numout,*) '   maximum ice concentration for SH                        = ', rn_amax_s 
     365         WRITE(numout,*) '   maximum ice concentration                               = ', rn_amax  
    373366         WRITE(numout,*) '   Diagnose heat/salt budget or not          ln_limdiahsb  = ', ln_limdiahsb 
    374367         WRITE(numout,*) '   Output   heat/salt budget or not          ln_limdiaout  = ', ln_limdiaout 
    … …  
    585578      sfx_bog(:,:) = 0._wp   ;   sfx_dyn(:,:) = 0._wp 
    586579      sfx_bom(:,:) = 0._wp   ;   sfx_sum(:,:) = 0._wp 
    587       sfx_res(:,:) = 0._wp   ;   sfx_sub(:,:) = 0._wp 
     580      sfx_res(:,:) = 0._wp 
    588581       
    589582      wfx_snw(:,:) = 0._wp   ;   wfx_ice(:,:) = 0._wp 
    … …  
    601594      hfx_spr(:,:) = 0._wp   ;   hfx_dif(:,:) = 0._wp  
    602595      hfx_err(:,:) = 0._wp   ;   hfx_err_rem(:,:) = 0._wp 
    603       hfx_err_dif(:,:) = 0._wp 
    604       wfx_err_sub(:,:) = 0._wp 
    605        
     596      hfx_err_dif(:,:) = 0._wp   ; 
     597 
    606598      afx_tot(:,:) = 0._wp   ; 
    607599      afx_dyn(:,:) = 0._wp   ;   afx_thd(:,:) = 0._wp 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcice_lim_2.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcisf.F90

    r6617 r6625  
    5353   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  risfLeff               !:effective length (Leff) BG03 nn_isf==2 
    5454   REAL(wp)   , PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  ttbl, stbl, utbl, vtbl !:top boundary layer variable at T point 
     55#if defined key_agrif 
     56   ! AGRIF can not handle these arrays as integers. The reason is a mystery but problems avoided by declaring them as reals 
     57   REAL(wp),    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
     58                                                                                          !: (first wet level and last level include in the tbl) 
     59#else 
    5560   INTEGER,    PUBLIC, ALLOCATABLE, SAVE, DIMENSION (:,:)     ::  misfkt, misfkb         !:Level of ice shelf base 
     61#endif 
    5662 
    5763 
    … …  
    8692    REAL(wp)                     ::   rmin 
    8793    REAL(wp)                     ::   zhk 
    88     REAL(wp)                     ::   zt_frz, zpress 
    89     CHARACTER(len=256)           ::   cfisf , cvarzisf, cvarhisf   ! name for isf file 
     94    CHARACTER(len=256)           ::   cfisf, cvarzisf, cvarhisf   ! name for isf file 
    9095    CHARACTER(LEN=256)           :: cnameis                     ! name of iceshelf file 
    9196    CHARACTER (LEN=32)           :: cvarLeff                    ! variable name for efficient Length scale 
    … …  
    171176              DO jj = 1, jpj 
    172177                  jk = 2 
    173                   DO WHILE ( jk .LE. mbkt(ji,jj) .AND. gdepw_0(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
     178                  DO WHILE ( jk .LE. mbkt(ji,jj) .AND. fsdepw(ji,jj,jk) < rzisf_tbl(ji,jj) ) ;  jk = jk + 1 ;  END DO 
    174179                  misfkt(ji,jj) = jk-1 
    175180               END DO 
    … …  
    189194         END IF 
    190195          
    191          ! save initial top boundary layer thickness          
    192196         rhisf_tbl_0(:,:) = rhisf_tbl(:,:) 
    193197 
     198         ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
     199         DO jj = 1,jpj 
     200            DO ji = 1,jpi 
     201               ikt = misfkt(ji,jj) 
     202               ikb = misfkt(ji,jj) 
     203               ! thickness of boundary layer at least the top level thickness 
     204               rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 
     205 
     206               ! determine the deepest level influenced by the boundary layer 
     207               ! test on tmask useless ????? 
     208               DO jk = ikt, mbkt(ji,jj) 
     209                  IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     210               END DO 
     211               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
     212               misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl 
     213               r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
     214 
     215               zhk           = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1 
     216               ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
     217            END DO 
     218         END DO 
     219          
    194220      END IF 
    195221 
    … …  
    204230      IF( MOD( kt-1, nn_fsbc) == 0 ) THEN 
    205231 
    206          ! compute bottom level of isf tbl and thickness of tbl below the ice shelf 
    207          DO jj = 1,jpj 
    208             DO ji = 1,jpi 
    209                ikt = misfkt(ji,jj) 
    210                ikb = misfkt(ji,jj) 
    211                ! thickness of boundary layer at least the top level thickness 
    212                rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), fse3t_n(ji,jj,ikt)) 
    213  
    214                ! determine the deepest level influenced by the boundary layer 
    215                DO jk = ikt, mbkt(ji,jj) 
    216                   IF ( (SUM(fse3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    217                END DO 
    218                rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t_n(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 
    219                misfkb(ji,jj) = ikb                                                  ! last wet level of the tbl 
    220                r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) 
    221  
    222                zhk           = SUM( fse3t(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj)  ! proportion of tbl cover by cell from ikt to ikb - 1 
    223                ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / fse3t(ji,jj,ikb)  ! proportion of bottom cell influenced by boundary layer 
    224             END DO 
    225          END DO 
    226232 
    227233         ! compute salf and heat flux 
    … …  
    264270         END IF 
    265271         ! compute tsc due to isf 
    266          ! WARNING water add at temp = 0C, correction term is added, maybe better here but need a 3D variable). 
    267 !         zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
    268          zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    269          risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - rdivisf * fwfisf(:,:) * zt_frz * r1_rau0 ! 
     272         ! WARNING water add at temp = 0C, correction term is added in trasbc, maybe better here but need a 3D variable). 
     273         risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp ! 
    270274          
    271275         ! salt effect already take into account in vertical advection 
    272276         risf_tsc(:,:,jp_sal) = (1.0_wp-rdivisf) * fwfisf(:,:) * stbl(:,:) * r1_rau0 
    273  
    274          ! output 
    275          IF( iom_use('qisf'  ) )   CALL iom_put('qisf'  , qisf) 
    276          IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    277  
    278          ! if apply only on the trend and not as a volume flux (rdivisf = 0), fwfisf have to be set to 0 now 
    279          fwfisf(:,:) = rdivisf * fwfisf(:,:)          
    280   
     277           
    281278         ! lbclnk 
    282279         CALL lbc_lnk(risf_tsc(:,:,jp_tem),'T',1.) 
    … …  
    298295         ENDIF 
    299296         !  
     297         ! output 
     298         CALL iom_put('qisf'  , qisf) 
     299         IF( iom_use('fwfisf') )   CALL iom_put('fwfisf', fwfisf * stbl(:,:) / soce ) 
    300300      END IF 
    301301   
    … …  
    370370             ! Calculate freezing temperature 
    371371                zpress = grav*rau0*fsdept(ji,jj,ik)*1.e-04  
    372                 CALL eos_fzp(tsb(ji,jj,ik,jp_sal), zt_frz, zpress)  
     372                zt_frz = eos_fzp(tsb(ji,jj,ik,jp_sal), zpress)  
    373373                zt_sum = zt_sum + (tsn(ji,jj,ik,jp_tem)-zt_frz) * fse3t(ji,jj,ik) * tmask(ji,jj,ik)  ! sum temp 
    374374             ENDDO 
    … …  
    452452      zti(:,:)=tinsitu( ttbl, stbl, zpress ) 
    453453! Calculate freezing temperature 
    454       CALL eos_fzp( sss_m(:,:), zfrz(:,:), zpress ) 
     454      zfrz(:,:)=eos_fzp( sss_m(:,:), zpress ) 
    455455 
    456456       
    … …  
    472472 
    473473                     nit = nit + 1 
    474                      IF (nit .GE. 100) CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
    475  
     474                     IF (nit .GE. 100) THEN 
     475                        !WRITE(numout,*) "sbcisf : too many iteration ... ", zhtflx, zhtflx_b,zgammat, rn_gammat0, rn_tfri2, nn_gammablk, ji,jj 
     476                        !WRITE(numout,*) "sbcisf : too many iteration ... ", (zhtflx - zhtflx_b)/zhtflx 
     477                        CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) 
     478                     END IF 
    476479! save gammat and compute zhtflx_b 
    477480                     zgammat2d(ji,jj)=zgammat 
    … …  
    791794               ! test on tmask useless ????? 
    792795               DO jk = ikt, mbkt(ji,jj) 
    793                   IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
     796!                  IF ( (SUM(fse3t(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk 
    794797               END DO 
    795798               rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(fse3t(ji,jj,ikt:ikb)))  ! limit the tbl to water thickness. 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcmod.F90

    r6617 r6625  
    179179 
    180180      !                          ! Checks: 
    181       IF( nn_isf .EQ. 0 ) THEN                      ! variable initialisation if no ice shelf  
     181      IF( nn_isf .EQ. 0 ) THEN                      ! no specific treatment in vicinity of ice shelf  
    182182         IF( sbc_isf_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) 
    183          fwfisf  (:,:)   = 0.0_wp ; fwfisf_b  (:,:)   = 0.0_wp 
    184          risf_tsc(:,:,:) = 0.0_wp ; risf_tsc_b(:,:,:) = 0.0_wp 
    185          rdivisf       = 0.0_wp 
     183         fwfisf  (:,:) = 0.0_wp 
     184         fwfisf_b(:,:) = 0.0_wp 
    186185      END IF 
    187186      IF( nn_ice == 0 .AND. nn_components /= jp_iam_opa )   fr_i(:,:) = 0.e0 ! no ice in the domain, ice fraction is always zero 
    … …  
    456455      !                                                ! ---------------------------------------- ! 
    457456      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN 
    458          CALL iom_put( "empmr"  , emp    - rnf )                ! upward water flux 
    459          CALL iom_put( "empbmr" , emp_b  - rnf )                ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) 
     457         CALL iom_put( "empmr" , emp  - rnf )                   ! upward water flux 
    460458         CALL iom_put( "saltflx", sfx  )                        ! downward salt flux   
    461459                                                                ! (includes virtual salt flux beneath ice  

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/sbcrnf.F90

    r6617 r6625  
    5252   REAL(wp)                   ::   rn_hrnf         !: runoffs, depth over which enhanced vertical mixing is used 
    5353   REAL(wp)          , PUBLIC ::   rn_avt_rnf      !: runoffs, value of the additional vertical mixing coef. [m2/s] 
    54    REAL(wp)          , PUBLIC ::   rn_rfact        !: multiplicative factor for runoff 
     54   REAL(wp)                  ::   rn_rfact        !: multiplicative factor for runoff 
    5555 
    5656   LOGICAL           , PUBLIC ::   l_rnfcpl = .false.       ! runoffs recieved from oasis 
    … …  
    125125      IF(   ln_rnf_tem   )   CALL fld_read ( kt, nn_fsbc, sf_t_rnf )    ! idem for runoffs temperature if required 
    126126      IF(   ln_rnf_sal   )   CALL fld_read ( kt, nn_fsbc, sf_s_rnf )    ! idem for runoffs salinity    if required 
     127      ! 
     128      ! Runoff reduction only associated to the ORCA2_LIM configuration 
     129      ! when reading the NetCDF file runoff_1m_nomask.nc 
     130      IF( cp_cfg == 'orca' .AND. jp_cfg == 2 .AND. .NOT. l_rnfcpl )   THEN 
     131         WHERE( 40._wp < gphit(:,:) .AND. gphit(:,:) < 65._wp ) 
     132            sf_rnf(1)%fnow(:,:,1) = 0.85 * sf_rnf(1)%fnow(:,:,1) 
     133         END WHERE 
     134      ENDIF 
    127135      ! 
    128136      IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SBC/updtide.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/SOL/solver.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/STO/stopar.F90

    r6617 r6625  
    849849 
    850850 
    851    FUNCTION sto_par_flt_fac( kpasses ) 
     851   REAL(wp) FUNCTION sto_par_flt_fac( kpasses ) 
    852852      !!---------------------------------------------------------------------- 
    853853      !!                  ***  FUNCTION sto_par_flt_fac  *** 
    … …  
    858858      !!---------------------------------------------------------------------- 
    859859      INTEGER, INTENT(in) :: kpasses 
    860       REAL(wp) :: sto_par_flt_fac 
    861860      !! 
    862861      INTEGER :: jpasses, ji, jj, jflti, jfltj 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/eosbn2.F90

    r6617 r6625  
    2222   !!             -   ! 2013-04  (F. Roquet, G. Madec)  add eos_rab, change bn2 computation and reorganize the module 
    2323   !!             -   ! 2014-09  (F. Roquet)  add TEOS-10, S-EOS, and modify EOS-80 
    24    !!             -   ! 2015-06  (P.A. Bouttier) eos_fzp functions changed to subroutines for AGRIF 
    2524   !!---------------------------------------------------------------------- 
    2625 
    … …  
    992991 
    993992 
    994    SUBROUTINE  eos_fzp_2d( psal, ptf, pdep ) 
     993   FUNCTION eos_fzp_2d( psal, pdep ) RESULT( ptf ) 
    995994      !!---------------------------------------------------------------------- 
    996995      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10061005      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   )           ::   psal   ! salinity   [psu] 
    10071006      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ), OPTIONAL ::   pdep   ! depth      [m] 
    1008       REAL(wp), DIMENSION(jpi,jpj), INTENT(out  )           ::   ptf    ! freezing temperature [Celcius] 
     1007      REAL(wp), DIMENSION(jpi,jpj)                          ::   ptf   ! freezing temperature [Celcius] 
    10091008      ! 
    10101009      INTEGER  ::   ji, jj   ! dummy loop indices 
    … …  
    10391038         nstop = nstop + 1 
    10401039         ! 
    1041       END SELECT       
    1042       ! 
    1043   END SUBROUTINE eos_fzp_2d 
    1044  
    1045   SUBROUTINE eos_fzp_0d( psal, ptf, pdep ) 
     1040      END SELECT 
     1041      ! 
     1042   END FUNCTION eos_fzp_2d 
     1043 
     1044  FUNCTION eos_fzp_0d( psal, pdep ) RESULT( ptf ) 
    10461045      !!---------------------------------------------------------------------- 
    10471046      !!                 ***  ROUTINE eos_fzp  *** 
    … …  
    10551054      !! Reference  :   UNESCO tech. papers in the marine science no. 28. 1978 
    10561055      !!---------------------------------------------------------------------- 
    1057       REAL(wp), INTENT(in )           ::   psal         ! salinity   [psu] 
    1058       REAL(wp), INTENT(in ), OPTIONAL ::   pdep         ! depth      [m] 
    1059       REAL(wp), INTENT(out)           ::   ptf          ! freezing temperature [Celcius] 
     1056      REAL(wp), INTENT(in)           ::   psal   ! salinity   [psu] 
     1057      REAL(wp), INTENT(in), OPTIONAL ::   pdep   ! depth      [m] 
     1058      REAL(wp)                       ::   ptf   ! freezing temperature [Celcius] 
    10601059      ! 
    10611060      REAL(wp) :: zs   ! local scalars 
    … …  
    10871086      END SELECT 
    10881087      ! 
    1089    END SUBROUTINE eos_fzp_0d 
     1088   END FUNCTION eos_fzp_0d 
    10901089 
    10911090 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_cen2.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_eiv.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/traadv_tvd.F90

    r6617 r6625  
    326326      CALL wrk_alloc( jpi, jpj, zwx_sav, zwy_sav ) 
    327327      CALL wrk_alloc( jpi, jpj, jpk, zwi, zwz , zhdiv, zwz_sav, zwzts ) 
    328       CALL wrk_alloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
     328      CALL wrk_alloc( jpi, jpj, jpk, 3, ztrs ) 
    329329      ! 
    330330      IF( kt == kit000 )  THEN 
    … …  
    564564      ! 
    565565                   CALL wrk_dealloc( jpi, jpj, jpk, zwi, zwz, zhdiv, zwz_sav, zwzts ) 
    566                    CALL wrk_dealloc( jpi, jpj, jpk, kjpt+1, ztrs ) 
     566                   CALL wrk_dealloc( jpi, jpj, jpk, 3, ztrs ) 
    567567                   CALL wrk_dealloc( jpi, jpj, zwx_sav, zwy_sav ) 
    568568      IF( l_trd )  CALL wrk_dealloc( jpi, jpj, jpk, ztrdx, ztrdy, ztrdz ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/traldf.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/tranxt.F90

    r6617 r6625  
    2828   USE sbc_oce         ! surface boundary condition: ocean 
    2929   USE sbcrnf          ! river runoffs 
    30    USE sbcisf          ! ice shelf melting/freezing 
    3130   USE zdf_oce         ! ocean vertical mixing 
    3231   USE domvvl          ! variable volume 
    … …  
    4746   USE timing          ! Timing 
    4847#if defined key_agrif 
     48   USE agrif_opa_update 
    4949   USE agrif_opa_interp 
    5050#endif 
    … …  
    110110      ! Update after tracer on domain lateral boundaries 
    111111      !  
     112      CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
     113      CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
     114      ! 
     115#if defined key_bdy  
     116      IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
     117#endif 
    112118#if defined key_agrif 
    113119      CALL Agrif_tra                     ! AGRIF zoom boundaries 
    114 #endif 
    115       ! 
    116       CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1._wp )      ! local domain boundaries  (T-point, unchanged sign) 
    117       CALL lbc_lnk( tsa(:,:,:,jp_sal), 'T', 1._wp ) 
    118       ! 
    119 #if defined key_bdy  
    120       IF( lk_bdy )   CALL bdy_tra( kt )  ! BDY open boundaries 
    121120#endif 
    122121  
    … …  
    149148         ELSE                 ;   CALL tra_nxt_fix( kt, nit000,         'TRA', tsb, tsn, tsa, jpts )  ! fixed    volume level  
    150149         ENDIF 
    151       ENDIF      
    152       ! 
    153      ! trends computation 
     150      ENDIF  
     151      ! 
     152#if defined key_agrif 
     153      ! Update tracer at AGRIF zoom boundaries 
     154      IF( .NOT.Agrif_Root() )    CALL Agrif_Update_Tra( kt )      ! children only 
     155#endif       
     156      ! 
     157      ! trends computation 
    154158      IF( l_trdtra ) THEN      ! trend of the Asselin filter (tb filtered - tb)/dt      
    155159         DO jk = 1, jpkm1 
    … …  
    275279 
    276280      !!      
    277       LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf, ll_isf   ! local logical 
     281      LOGICAL  ::   ll_tra_hpg, ll_traqsr, ll_rnf   ! local logical 
    278282      INTEGER  ::   ji, jj, jk, jn              ! dummy loop indices 
    279283      REAL(wp) ::   zfact1, ztc_a , ztc_n , ztc_b , ztc_f , ztc_d    ! local scalar 
    … …  
    291295         ll_traqsr  = ln_traqsr        ! active  tracers case  and  solar penetration 
    292296         ll_rnf     = ln_rnf           ! active  tracers case  and  river runoffs 
    293          IF (nn_isf .GE. 1) THEN  
    294             ll_isf = .TRUE.            ! active  tracers case  and  ice shelf melting/freezing 
    295          ELSE 
    296             ll_isf = .FALSE. 
    297          END IF 
    298297      ELSE                           
    299298         ll_tra_hpg = .FALSE.          ! passive tracers case or NO semi-implicit hpg 
    300299         ll_traqsr  = .FALSE.          ! active  tracers case and NO solar penetration 
    301300         ll_rnf     = .FALSE.          ! passive tracers or NO river runoffs 
    302          ll_isf     = .FALSE.          ! passive tracers or NO ice shelf melting/freezing 
    303301      ENDIF 
    304302      ! 
    … …  
    323321                  ztc_f  = ztc_n  + atfp * ztc_d 
    324322                  ! 
    325                   IF( jk == mikt(ji,jj) ) THEN           ! first level  
    326                      ze3t_f = ze3t_f - zfact2 * ( (emp_b(ji,jj)    - emp(ji,jj)   )  & 
    327                             &                   - (rnf_b(ji,jj)    - rnf(ji,jj)   )  & 
    328                             &                   + (fwfisf_b(ji,jj) - fwfisf(ji,jj))  ) 
     323                  IF( jk == 1 ) THEN           ! first level  
     324                     ze3t_f = ze3t_f - zfact2 * ( emp_b(ji,jj) - emp(ji,jj) + rnf(ji,jj) - rnf_b(ji,jj) ) 
    329325                     ztc_f  = ztc_f  - zfact1 * ( psbc_tc(ji,jj,jn) - psbc_tc_b(ji,jj,jn) ) 
    330326                  ENDIF 
    331327 
    332                   ! solar penetration (temperature only) 
    333                   IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )                            &  
     328                  IF( ll_traqsr .AND. jn == jp_tem .AND. jk <= nksr )   &     ! solar penetration (temperature only) 
    334329                     &     ztc_f  = ztc_f  - zfact1 * ( qsr_hc(ji,jj,jk) - qsr_hc_b(ji,jj,jk) )  
    335330 
    336                   ! river runoff 
    337                   IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )                                          & 
     331                  IF( ll_rnf .AND. jk <= nk_rnf(ji,jj) )   &            ! river runoffs 
    338332                     &     ztc_f  = ztc_f  - zfact1 * ( rnf_tsc(ji,jj,jn) - rnf_tsc_b(ji,jj,jn) ) &  
    339333                     &                              * fse3t_n(ji,jj,jk) / h_rnf(ji,jj) 
    340  
    341                   ! ice shelf 
    342                   IF( ll_isf ) THEN 
    343                      ! level fully include in the Losch_2008 ice shelf boundary layer 
    344                      IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) )                          & 
    345                         ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
    346                                &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) 
    347                      ! level partially include in Losch_2008 ice shelf boundary layer  
    348                      IF ( jk == misfkb(ji,jj) )                                                   & 
    349                         ztc_f  = ztc_f  - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) )  & 
    350                                &                 * fse3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) 
    351                   END IF 
    352334 
    353335                  ze3t_f = 1.e0 / ze3t_f 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/traqsr.F90

    r6617 r6625  
    1010   !!             -   !  2005-11  (G. Madec) zco, zps, sco coordinate 
    1111   !!            3.2  !  2009-04  (G. Madec & NEMO team)  
    12    !!            3.4  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
    13    !!            3.6  !  2015-12  (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll 
     12   !!            4.0  !  2012-05  (C. Rousset) store attenuation coef for use in ice model  
    1413   !!---------------------------------------------------------------------- 
    1514 
    … …  
    9493      !! Reference  : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp. 
    9594      !!              Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516. 
    96       !!              Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562 
    9795      !!---------------------------------------------------------------------- 
    9896      ! 
    … …  
    103101      REAL(wp) ::   zchl, zcoef, zfact   ! local scalars 
    104102      REAL(wp) ::   zc0, zc1, zc2, zc3   !    -         - 
     103      REAL(wp) ::   zzc0, zzc1, zzc2, zzc3   !    -         - 
    105104      REAL(wp) ::   zz0, zz1, z1_e3t     !    -         - 
    106       REAL(wp) ::   zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze 
    107       REAL(wp) ::   zlogc, zlogc2, zlogc3  
    108105      REAL(wp), POINTER, DIMENSION(:,:  ) :: zekb, zekg, zekr 
    109       REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt, zchl3d 
    110       !!-------------------------------------------------------------------------- 
     106      REAL(wp), POINTER, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt 
     107      !!---------------------------------------------------------------------- 
    111108      ! 
    112109      IF( nn_timing == 1 )  CALL timing_start('tra_qsr') 
    113110      ! 
    114111      CALL wrk_alloc( jpi, jpj,      zekb, zekg, zekr        )  
    115       CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
     112      CALL wrk_alloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    116113      ! 
    117114      IF( kt == nit000 ) THEN 
    … …  
    186183            !                                             ! ------------------------- ! 
    187184            ! Set chlorophyl concentration 
    188             IF( nn_chldta == 1 .OR. nn_chldta == 2 .OR. lk_vvl ) THEN    !*  Variable Chlorophyll or ocean volume 
    189                ! 
    190                IF( nn_chldta == 1 ) THEN        !*  2D Variable Chlorophyll 
     185            IF( nn_chldta == 1 .OR. lk_vvl ) THEN            !*  Variable Chlorophyll or ocean volume 
     186               ! 
     187               IF( nn_chldta == 1 ) THEN                             !* Variable Chlorophyll 
    191188                  ! 
    192                   CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
    193                   DO jk = 1, nksr + 1 
    194                      zchl3d(:,:,jk) = sf_chl(1)%fnow(:,:,1)  
    195                   ENDDO 
    196                   ! 
    197                ELSE IF( nn_chldta == 2 ) THEN    !*   -3-D Variable Chlorophyll 
    198                   ! 
    199                   CALL fld_read( kt, 1, sf_chl )            ! Read Chl data and provides it at the current time step 
    200 !CDIR NOVERRCHK   ! 
    201                   DO jj = 1, jpj 
     189                  CALL fld_read( kt, 1, sf_chl )                         ! Read Chl data and provides it at the current time step 
     190                  !          
     191!CDIR COLLAPSE 
     192!CDIR NOVERRCHK 
     193                  DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    202194!CDIR NOVERRCHK 
    203195                     DO ji = 1, jpi 
    204                         zchl    = sf_chl(1)%fnow(ji,jj,1) 
    205                         zCtot   = 40.6  * zchl**0.459 
    206                         zze     = 568.2 * zCtot**(-0.746) 
    207                         IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) 
    208                         zlogc   = LOG( zchl ) 
    209                         zlogc2  = zlogc * zlogc 
    210                         zlogc3  = zlogc * zlogc * zlogc 
    211                         zCb     = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 
    212                         zCmax   = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 
    213                         zpsimax = 0.6   - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 
    214                         zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 
    215                         zCze    = 1.12  * (zchl)**0.803  
    216                         DO jk = 1, nksr + 1 
    217                            zpsi = fsdept(ji,jj,jk) / zze 
    218                            zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) 
    219                         END DO 
    220                         ! 
    221                       END DO 
    222                    END DO 
    223                      ! 
    224                ELSE                              !* Variable ocean volume but constant chrlorophyll 
    225                   DO jk = 1, nksr + 1 
    226                      zchl3d(:,:,jk) = 0.05  
    227                   ENDDO 
    228                ENDIF 
    229                ! 
    230                zcoef  = ( 1. - rn_abs ) / 3.e0                        !  equi-partition in R-G-B 
     196                        zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) 
     197                        irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
     198                        zekb(ji,jj) = rkrgb(1,irgb) 
     199                        zekg(ji,jj) = rkrgb(2,irgb) 
     200                        zekr(ji,jj) = rkrgb(3,irgb) 
     201                     END DO 
     202                  END DO 
     203               ELSE                                            ! Variable ocean volume but constant chrlorophyll 
     204                  zchl = 0.05                                     ! constant chlorophyll 
     205                  irgb = NINT( 41 + 20.*LOG10( zchl ) + 1.e-15 ) 
     206                  zekb(:,:) = rkrgb(1,irgb)                       ! Separation in R-G-B depending of the chlorophyll  
     207                  zekg(:,:) = rkrgb(2,irgb) 
     208                  zekr(:,:) = rkrgb(3,irgb) 
     209               ENDIF 
     210               ! 
     211               zcoef  = ( 1. - rn_abs ) / 3.e0                        ! equi-partition in R-G-B 
    231212               ze0(:,:,1) = rn_abs  * qsr(:,:) 
    232213               ze1(:,:,1) = zcoef * qsr(:,:) 
    … …  
    236217               ! 
    237218               DO jk = 2, nksr+1 
    238                   ! 
    239                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of vertical profile of Chl 
    240 !CDIR NOVERRCHK 
    241                      DO ji = 1, jpi 
    242                         zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) 
    243                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    244                         zekb(ji,jj) = rkrgb(1,irgb) 
    245                         zekg(ji,jj) = rkrgb(2,irgb) 
    246                         zekr(ji,jj) = rkrgb(3,irgb) 
    247                      END DO 
    248                   END DO 
    249219!CDIR NOVERRCHK 
    250220                  DO jj = 1, jpj 
    … …  
    263233                  END DO 
    264234               END DO 
     235               ! clem: store attenuation coefficient of the first ocean level 
     236               IF ( ln_qsr_ice ) THEN 
     237                  DO jj = 1, jpj 
     238                     DO ji = 1, jpi 
     239                        zzc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
     240                        zzc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
     241                        zzc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
     242                        zzc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
     243                        fraqsr_1lev(ji,jj) = 1.0 - ( zzc0 + zzc1 + zzc2  + zzc3  ) * tmask(ji,jj,2)  
     244                     END DO 
     245                  END DO 
     246               ENDIF 
    265247               ! 
    266248               DO jk = 1, nksr                                        ! compute and add qsr trend to ta 
    … …  
    269251               zea(:,:,nksr+1:jpk) = 0.e0     ! below 400m set to zero 
    270252               CALL iom_put( 'qsr3d', zea )   ! Shortwave Radiation 3D distribution 
    271                ! 
    272                IF ( ln_qsr_ice ) THEN    ! store attenuation coefficient of the first ocean level 
    273 !CDIR NOVERRCHK 
    274                   DO jj = 1, jpj                                         ! Separation in R-G-B depending of the surface Chl 
    275 !CDIR NOVERRCHK 
    276                      DO ji = 1, jpi 
    277                         zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,1) ) ) 
    278                         irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) 
    279                         zekb(ji,jj) = rkrgb(1,irgb) 
    280                         zekg(ji,jj) = rkrgb(2,irgb) 
    281                         zekr(ji,jj) = rkrgb(3,irgb) 
    282                      END DO 
    283                   END DO 
    284                   !  
    285                   DO jj = 1, jpj 
    286                      DO ji = 1, jpi 
    287                         zc0 = rn_abs * EXP( - fse3t(ji,jj,1) * xsi0r     ) 
    288                         zc1 = zcoef  * EXP( - fse3t(ji,jj,1) * zekb(ji,jj) ) 
    289                         zc2 = zcoef  * EXP( - fse3t(ji,jj,1) * zekg(ji,jj) ) 
    290                         zc3 = zcoef  * EXP( - fse3t(ji,jj,1) * zekr(ji,jj) ) 
    291                         fraqsr_1lev(ji,jj) = 1.0 - ( zc0 + zc1 + zc2  + zc3  ) * tmask(ji,jj,2)  
    292                      END DO 
    293                   END DO 
    294                   ! 
    295                ENDIF 
    296253               ! 
    297254            ELSE                                                 !*  Constant Chlorophyll 
    … …  
    299256                  qsr_hc(:,:,jk) =  etot3(:,:,jk) * qsr(:,:) 
    300257               END DO 
    301                ! store attenuation coefficient of the first ocean level 
    302                IF( ln_qsr_ice ) THEN 
     258               ! clem: store attenuation coefficient of the first ocean level 
     259               IF ( ln_qsr_ice ) THEN 
    303260                  fraqsr_1lev(:,:) = etot3(:,:,1) / r1_rau0_rcp 
    304261               ENDIF 
    … …  
    382339      ! 
    383340      CALL wrk_dealloc( jpi, jpj,      zekb, zekg, zekr        )  
    384       CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea, zchl3d )  
     341      CALL wrk_dealloc( jpi, jpj, jpk, ze0, ze1, ze2, ze3, zea )  
    385342      ! 
    386343      IF( nn_timing == 1 )  CALL timing_stop('tra_qsr') 
    … …  
    448405         WRITE(numout,*) '      bio-model            light penetration   ln_qsr_bio = ', ln_qsr_bio 
    449406         WRITE(numout,*) '      light penetration for ice-model LIM3     ln_qsr_ice = ', ln_qsr_ice 
    450          WRITE(numout,*) '      RGB : Chl data (=1/2) or cst value (=0)  nn_chldta  = ', nn_chldta 
     407         WRITE(numout,*) '      RGB : Chl data (=1) or cst value (=0)    nn_chldta  = ', nn_chldta 
    451408         WRITE(numout,*) '      RGB & 2 bands: fraction of light (rn_si1)    rn_abs = ', rn_abs 
    452409         WRITE(numout,*) '      RGB & 2 bands: shortess depth of extinction  rn_si0 = ', rn_si0 
    … …  
    472429         IF( ln_qsr_rgb .AND. nn_chldta == 0 )   nqsr =  1  
    473430         IF( ln_qsr_rgb .AND. nn_chldta == 1 )   nqsr =  2 
    474          IF( ln_qsr_rgb .AND. nn_chldta == 2 )   nqsr =  3 
    475          IF( ln_qsr_2bd                      )   nqsr =  4 
    476          IF( ln_qsr_bio                      )   nqsr =  5 
     431         IF( ln_qsr_2bd                      )   nqsr =  3 
     432         IF( ln_qsr_bio                      )   nqsr =  4 
    477433         ! 
    478434         IF(lwp) THEN                   ! Print the choice 
    479435            WRITE(numout,*) 
    480436            IF( nqsr ==  1 )   WRITE(numout,*) '         R-G-B   light penetration - Constant Chlorophyll' 
    481             IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - 2D Chl data ' 
    482             IF( nqsr ==  3 )   WRITE(numout,*) '         R-G-B   light penetration - 3D Chl data ' 
    483             IF( nqsr ==  4 )   WRITE(numout,*) '         2 bands light penetration' 
    484             IF( nqsr ==  5 )   WRITE(numout,*) '         bio-model light penetration' 
     437            IF( nqsr ==  2 )   WRITE(numout,*) '         R-G-B   light penetration - Chl data ' 
     438            IF( nqsr ==  3 )   WRITE(numout,*) '         2 bands light penetration' 
     439            IF( nqsr ==  4 )   WRITE(numout,*) '         bio-model light penetration' 
    485440         ENDIF 
    486441         ! 
    … …  
    505460            IF(lwp) WRITE(numout,*) '        level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m' 
    506461            ! 
    507             IF( nn_chldta == 1  .OR. nn_chldta == 2 ) THEN           !* Chl data : set sf_chl structure 
     462            IF( nn_chldta == 1 ) THEN           !* Chl data : set sf_chl structure 
    508463               IF(lwp) WRITE(numout,*) 
    509464               IF(lwp) WRITE(numout,*) '        Chlorophyll read in a file' 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRA/trasbc.F90

    r6617 r6625  
    120120      REAL(wp) ::   zfact, z1_e3t, zdep 
    121121      REAL(wp) ::   zalpha, zhk 
     122      REAL(wp) ::  zt_frz, zpress 
    122123      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrdt, ztrds 
    123124      !!---------------------------------------------------------------------- 
    … …  
    231232               DO jk = ikt, ikb - 1 
    232233               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
     234!                  zpress = grav*rau0*fsdept(ji,jj,jk)*1.e-04 
     235                  zt_frz = -1.9 !eos_fzp( tsn(ji,jj,jk,jp_sal), zpress ) 
    233236               ! compute trend 
    234237                  tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem)                                          & 
    235                      &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) 
     238                     &           + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
     239                     &               - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) & 
     240                     &           * r1_hisf_tbl(ji,jj) 
    236241                  tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal)                                          & 
    237242                     &           + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) 
    … …  
    240245               ! level partially include in ice shelf boundary layer  
    241246               ! compute tfreez for the temperature correction (we add water at freezing temperature) 
     247!               zpress = grav*rau0*fsdept(ji,jj,ikb)*1.e-04 
     248               zt_frz = -1.9 !eos_fzp( tsn(ji,jj,ikb,jp_sal), zpress ) 
    242249               ! compute trend 
    243250               tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem)                                           & 
    244                   &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
     251                  &              + zfact * (risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem)          & 
     252                  &                  - rdivisf * (fwfisf(ji,jj) + fwfisf_b(ji,jj)) * zt_frz * r1_rau0) &  
     253                  &              * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) 
    245254               tsa(ji,jj,ikb,jp_sal) = tsa(ji,jj,ikb,jp_sal)                                           & 
    246255                  &              + zfact * (risf_tsc_b(ji,jj,jp_sal) + risf_tsc(ji,jj,jp_sal)) * r1_hisf_tbl(ji,jj) * ralpha(ji,jj)  

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRD/trdken.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRD/trdmxl_oce.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/TRD/trdpen.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdf_oce.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfddm.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfgls.F90

    r6617 r6625  
    4242   LOGICAL , PUBLIC, PARAMETER ::   lk_zdfgls = .TRUE.   !: TKE vertical mixing flag 
    4343   ! 
     44   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en      !: now turbulent kinetic energy 
    4445   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   mxln    !: now mixing length 
    4546   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   zwall   !: wall function 
     47   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k   ! not enhanced Kz 
     48   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avm_k   ! not enhanced Kz 
     49   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k  ! not enhanced Kz 
     50   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmv_k  ! not enhanced Kz 
    4651   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustars2 !: Squared surface velocity scale at T-points 
    4752   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   ustarb2 !: Squared bottom  velocity scale at T-points 
    … …  
    115120      !!                ***  FUNCTION zdf_gls_alloc  *** 
    116121      !!---------------------------------------------------------------------- 
    117       ALLOCATE( mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
    118          &      ustars2(jpi,jpj) , ustarb2(jpi,jpj)   , STAT= zdf_gls_alloc ) 
     122      ALLOCATE( en(jpi,jpj,jpk),  mxln(jpi,jpj,jpk), zwall(jpi,jpj,jpk) ,     & 
     123         &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                    & 
     124         &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk),                    & 
     125         &      ustars2(jpi,jpj), ustarb2(jpi,jpj)                      , STAT= zdf_gls_alloc ) 
    119126         ! 
    120127      IF( lk_mpp             )   CALL mpp_sum ( zdf_gls_alloc ) 
    … …  
    322329      !  
    323330      ! One level below 
    324       en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2)) & 
    325           &            / zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
     331      en(:,:,2) = rc02r * ustars2(:,:) * (1._wp + rsbc_tke1 * ((zhsro(:,:)+fsdepw(:,:,2))/zhsro(:,:) )**(1.5_wp*ra_sf))**(2._wp/3._wp) 
    326332      en(:,:,2) = MAX(en(:,:,2), rn_emin ) 
    327333      z_elem_a(:,:,2) = 0._wp  
    … …  
    344350      z_elem_a(:,:,2) = 0._wp 
    345351      zkar(:,:)       = (rl_sf + (vkarmn-rl_sf)*(1.-exp(-rtrans*fsdept(:,:,1)/zhsro(:,:)) )) 
    346       zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) & 
    347            &                      * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
     352      zflxs(:,:)      = rsbc_tke2 * ustars2(:,:)**1.5_wp * zkar(:,:) * ((zhsro(:,:)+fsdept(:,:,1))/zhsro(:,:) )**(1.5_wp*ra_sf) 
    348353 
    349354      en(:,:,2) = en(:,:,2) + zflxs(:,:)/fse3w(:,:,2) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdfmxl.F90

    r6617 r6625  
    2727 
    2828   PUBLIC   zdf_mxl       ! called by step.F90 
    29    PUBLIC   zdf_mxl_alloc ! Used in zdf_tke_init 
    3029 
    3130   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   nmln    !: number of level in the mixed layer (used by TOP) 
    … …  
    8079      INTEGER, INTENT(in) ::   kt   ! ocean time-step index 
    8180      ! 
    82       INTEGER  ::   ji, jj, jk      ! dummy loop indices 
    83       INTEGER  ::   iikn, iiki, ikt ! local integer 
    84       REAL(wp) ::   zN2_c           ! local scalar 
     81      INTEGER  ::   ji, jj, jk   ! dummy loop indices 
     82      INTEGER  ::   iikn, iiki, ikt, imkt  ! local integer 
     83      REAL(wp) ::   zN2_c        ! local scalar 
    8584      INTEGER, POINTER, DIMENSION(:,:) ::   imld   ! 2D workspace 
    8685      !!---------------------------------------------------------------------- 
    … …  
    117116         DO jj = 1, jpj 
    118117            DO ji = 1, jpi 
    119                IF( avt (ji,jj,jk) < avt_c * wmask(ji,jj,jk) )   imld(ji,jj) = jk      ! Turbocline  
     118               imkt = mikt(ji,jj) 
     119               IF( avt (ji,jj,jk) < avt_c )   imld(ji,jj) = MAX( imkt, jk )      ! Turbocline  
    120120            END DO 
    121121         END DO 
    … …  
    126126            iiki = imld(ji,jj) 
    127127            iikn = nmln(ji,jj) 
    128             hmld (ji,jj) = fsdepw(ji,jj,iiki  ) * ssmask(ji,jj)    ! Turbocline depth  
    129             hmlp (ji,jj) = fsdepw(ji,jj,iikn  ) * ssmask(ji,jj)    ! Mixed layer depth 
    130             hmlpt(ji,jj) = fsdept(ji,jj,iikn-1) * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
     128            imkt = mikt(ji,jj) 
     129            hmld (ji,jj) = ( fsdepw(ji,jj,iiki  ) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! Turbocline depth  
     130            hmlp (ji,jj) = ( fsdepw(ji,jj,iikn  ) - fsdepw(ji,jj,MAX( imkt,nla10 ) ) ) * ssmask(ji,jj)    ! Mixed layer depth 
     131            hmlpt(ji,jj) = ( fsdept(ji,jj,iikn-1) - fsdepw(ji,jj,imkt )            )   * ssmask(ji,jj)    ! depth of the last T-point inside the mixed layer 
    131132         END DO 
    132133      END DO 
    133       ! no need to output in offline mode 
    134       IF( .NOT.lk_offline ) THEN    
    135          IF ( iom_use("mldr10_1") ) THEN 
    136             IF( ln_isfcav ) THEN 
    137                CALL iom_put( "mldr10_1", hmlp - risfdep)   ! mixed layer thickness 
    138             ELSE 
    139                CALL iom_put( "mldr10_1", hmlp )            ! mixed layer depth 
    140             END IF 
    141          END IF 
    142          IF ( iom_use("mldkz5") ) THEN 
    143             IF( ln_isfcav ) THEN 
    144                CALL iom_put( "mldkz5"  , hmld - risfdep )   ! turbocline thickness 
    145             ELSE 
    146                CALL iom_put( "mldkz5"  , hmld )             ! turbocline depth 
    147             END IF 
    148          END IF 
     134      IF( .NOT.lk_offline ) THEN            ! no need to output in offline mode 
     135         CALL iom_put( "mldr10_1", hmlp )   ! mixed layer depth 
     136         CALL iom_put( "mldkz5"  , hmld )   ! turbocline depth 
    149137      ENDIF 
    150138       

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftke.F90

    r6617 r6625  
    5353   USE timing         ! Timing 
    5454   USE lib_fortran    ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined)   
    55 #if defined key_agrif 
    56    USE agrif_opa_interp 
    57    USE agrif_opa_update 
    58 #endif 
    59  
    60  
    6155 
    6256   IMPLICIT NONE 
    … …  
    9185   REAL(wp) ::   rhftau_scl = 1.0_wp       ! scale factor applied to HF part of taum  (nn_etau=3) 
    9286 
     87   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   en             !: now turbulent kinetic energy   [m2/s2] 
    9388   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   htau           ! depth of tke penetration (nn_htau) 
    9489   REAL(wp)        , ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dissl          ! now mixing lenght of dissipation 
     90   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avt_k , avm_k  ! not enhanced Kz 
     91   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   avmu_k, avmv_k ! not enhanced Kz 
    9592#if defined key_c1d 
    9693   !                                                                        !!** 1D cfg only  **   ('key_c1d') 
    … …  
    118115         &      e_pdl(jpi,jpj,jpk) , e_ric(jpi,jpj,jpk) ,                          & 
    119116#endif 
    120          &      htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) , STAT= zdf_tke_alloc      ) 
     117         &      en    (jpi,jpj,jpk) , htau  (jpi,jpj)    , dissl(jpi,jpj,jpk) ,     &  
     118         &      avt_k (jpi,jpj,jpk) , avm_k (jpi,jpj,jpk),                          & 
     119         &      avmu_k(jpi,jpj,jpk) , avmv_k(jpi,jpj,jpk), STAT= zdf_tke_alloc      ) 
    121120         ! 
    122121      IF( lk_mpp             )   CALL mpp_sum ( zdf_tke_alloc ) 
    … …  
    190189      avmv_k(:,:,:) = avmv(:,:,:)  
    191190      ! 
    192 #if defined key_agrif 
    193       ! Update child grid f => parent grid  
    194       IF( .NOT.Agrif_Root() )   CALL Agrif_Update_Tke( kt )      ! children only 
    195 #endif       
    196      !  
    197191   END SUBROUTINE zdf_tke 
    198192 
    … …  
    323317                  zwlc = zind * rn_lc * zus * SIN( rpi * fsdepw(ji,jj,jk) / zhlc(ji,jj) ) 
    324318                  !                                           ! TKE Langmuir circulation source term 
    325                   en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( 1._wp - fr_i(ji,jj) ) * ( zwlc * zwlc * zwlc ) /   & 
    326                      &   zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
     319                  en(ji,jj,jk) = en(ji,jj,jk) + rdt * ( zwlc * zwlc * zwlc ) / zhlc(ji,jj) * wmask(ji,jj,jk) * tmask(ji,jj,1) 
    327320               END DO 
    328321            END DO 
    … …  
    357350            DO ji = fs_2, fs_jpim1   ! vector opt. 
    358351               zcof   = zfact1 * tmask(ji,jj,jk) 
    359 # if defined key_zdftmx_new 
    360                ! key_zdftmx_new: New internal wave-driven param: set a minimum value for Kz on TKE (ensure numerical stability) 
    361                zzd_up = zcof * ( MAX( avm(ji,jj,jk+1) + avm(ji,jj,jk), 2.e-5_wp ) )   &  ! upper diagonal 
    362                   &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    363                zzd_lw = zcof * ( MAX( avm(ji,jj,jk) + avm(ji,jj,jk-1), 2.e-5_wp ) )   &  ! lower diagonal 
    364                   &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
    365 # else 
    366352               zzd_up = zcof * ( avm  (ji,jj,jk+1) + avm  (ji,jj,jk  ) )   &  ! upper diagonal 
    367353                  &          / ( fse3t(ji,jj,jk  ) * fse3w(ji,jj,jk  ) ) 
    368354               zzd_lw = zcof * ( avm  (ji,jj,jk  ) + avm  (ji,jj,jk-1) )   &  ! lower diagonal 
    369355                  &          / ( fse3t(ji,jj,jk-1) * fse3w(ji,jj,jk  ) ) 
    370 # endif 
    371356                  !                                                           ! shear prod. at w-point weightened by mask 
    372357               zesh2  =  ( avmu(ji-1,jj,jk) + avmu(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) )   & 
    … …  
    725710      !!---------------------------------------------------------------------- 
    726711      INTEGER ::   ji, jj, jk   ! dummy loop indices 
    727       INTEGER ::   ios, ierr 
     712      INTEGER ::   ios 
    728713      !! 
    729714      NAMELIST/namzdf_tke/ rn_ediff, rn_ediss , rn_ebb , rn_emin  ,   & 
    … …  
    743728      ! 
    744729      ri_cri   = 2._wp    / ( 2._wp + rn_ediss / rn_ediff )   ! resulting critical Richardson number 
    745 # if defined key_zdftmx_new 
    746       ! key_zdftmx_new: New internal wave-driven param: specified value of rn_emin & rmxl_min are used 
    747       rn_emin  = 1.e-10_wp 
    748       rmxl_min = 1.e-03_wp 
    749       IF(lwp) THEN                  ! Control print 
    750          WRITE(numout,*) 
    751          WRITE(numout,*) 'zdf_tke_init :  New tidal mixing case: force rn_emin = 1.e-10 and rmxl_min = 1.e-3 ' 
    752          WRITE(numout,*) '~~~~~~~~~~~~' 
    753       ENDIF 
    754 # else 
    755730      rmxl_min = 1.e-6_wp / ( rn_ediff * SQRT( rn_emin ) )    ! resulting minimum length to recover molecular viscosity 
    756 # endif 
    757731      ! 
    758732      IF(lwp) THEN                    !* Control print 
    … …  
    794768      ENDIF 
    795769       
    796       IF( nn_etau == 2  ) THEN 
    797           ierr = zdf_mxl_alloc() 
    798           nmln(:,:) = nlb10           ! Initialization of nmln 
    799       ENDIF 
     770      IF( nn_etau == 2  )   CALL zdf_mxl( nit000 )      ! Initialization of nmln  
    800771 
    801772      !                               !* depth of penetration of surface tke 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/ZDF/zdftmx.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r6617 r6625  
    161161          ENDIF 
    162162 
    163 #if defined key_agrif 
    164           CALL Agrif_Regrid() 
    165 #endif 
    166  
    167163         DO WHILE ( istp <= nitend .AND. nstop == 0 ) 
    168164#if defined key_agrif 
    169             CALL stp                         ! AGRIF: time stepping 
     165            CALL Agrif_Step( stp )           ! AGRIF: time stepping 
    170166#else 
    171167            CALL stp( istp )                 ! standard time stepping 
    … …  
    191187      ! 
    192188#if defined key_agrif 
    193       IF( .NOT. Agrif_Root() ) THEN 
    194          CALL Agrif_ParentGrid_To_ChildGrid() 
    195          IF( lk_diaobs ) CALL dia_obs_wri 
    196          IF( nn_timing == 1 )   CALL timing_finalize 
    197          CALL Agrif_ChildGrid_To_ParentGrid() 
    198       ENDIF 
     189      CALL Agrif_ParentGrid_To_ChildGrid() 
     190      IF( lk_diaobs ) CALL dia_obs_wri 
     191      IF( nn_timing == 1 )   CALL timing_finalize 
     192      CALL Agrif_ChildGrid_To_ParentGrid() 
    199193#endif 
    200194      IF( nn_timing == 1 )   CALL timing_finalize 
    … …  
    340334         jpj = ( jpjglo-2*jprecj + (jpnj-1) ) / jpnj + 2*jprecj   ! second dim. 
    341335#endif 
    342       ENDIF          
     336      ENDIF 
    343337         jpk = jpkdta                                             ! third dim 
    344 #if defined key_agrif 
    345          ! simple trick to use same vertical grid as parent 
    346          ! but different number of levels:  
    347          ! Save maximum number of levels in jpkdta, then define all vertical grids 
    348          ! with this number. 
    349          ! Suppress once vertical online interpolation is ok 
    350          IF(.NOT.Agrif_Root()) jpkdta = Agrif_Parent(jpkdta) 
    351 #endif 
    352338         jpim1 = jpi-1                                            ! inner domain indices 
    353339         jpjm1 = jpj-1                                            !   "           " 
    … …  
    724710      INTEGER :: ifac, jl, inu 
    725711      INTEGER, PARAMETER :: ntest = 14 
    726       INTEGER, DIMENSION(ntest) :: ilfax 
    727       ! 
    728       ! ilfax contains the set of allowed factors. 
    729       ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
    730       !!---------------------------------------------------------------------- 
    731       ! ilfax contains the set of allowed factors. 
    732       ilfax(:) = (/(2**jl,jl=ntest,1,-1)/) 
     712      INTEGER :: ilfax(ntest) 
     713      ! 
     714      ! lfax contains the set of allowed factors. 
     715      data (ilfax(jl),jl=1,ntest) / 16384, 8192, 4096, 2048, 1024, 512, 256,  & 
     716         &                            128,   64,   32,   16,    8,   4,   2  / 
     717      !!---------------------------------------------------------------------- 
    733718 
    734719      ! Clear the error flag and initialise output vars 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/step.F90

    r6617 r6625  
    5050 
    5151#if defined key_agrif 
    52    RECURSIVE SUBROUTINE stp( ) 
     52   SUBROUTINE stp( ) 
    5353      INTEGER             ::   kstp   ! ocean time-step index 
    5454#else 
    … …  
    7979#if defined key_agrif 
    8080      kstp = nit000 + Agrif_Nb_Step() 
    81       IF ( lk_agrif_debug ) THEN 
    82          IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
    83          IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp, 'int tstep',Agrif_NbStepint() 
    84       ENDIF 
    85  
     81!      IF ( Agrif_Root() .and. lwp) Write(*,*) '---' 
     82!      IF (lwp) Write(*,*) 'Grid Number',Agrif_Fixed(),' time step ',kstp 
    8683      IF ( kstp == (nit000 + 1) ) lk_agrif_fstep = .FALSE. 
    87  
    8884# if defined key_iomput 
    8985      IF( Agrif_Nbstepint() == 0 )   CALL iom_swap( cxios_context ) 
    … …  
    114110      ! Update stochastic parameters and random T/S fluctuations 
    115111      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    116        IF( ln_sto_eos ) CALL sto_par( kstp )          ! Stochastic parameters 
    117        IF( ln_sto_eos ) CALL sto_pts( tsn  )          ! Random T/S fluctuations 
     112                        CALL sto_par( kstp )          ! Stochastic parameters 
    118113 
    119114      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    157152      ! 
    158153      IF( lk_ldfslp ) THEN                            ! slope of lateral mixing 
     154         IF(ln_sto_eos ) CALL sto_pts( tsn )          ! Random T/S fluctuations 
    159155                         CALL eos( tsb, rhd, gdept_0(:,:,:) )               ! before in situ density 
    160156         IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    192188          ! Note that the computation of vertical velocity above, hence "after" sea level 
    193189          ! is necessary to compute momentum advection for the rhs of barotropic loop: 
     190            IF(ln_sto_eos ) CALL sto_pts( tsn )                             ! Random T/S fluctuations 
    194191                            CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) ) ! now in situ density for hpg computation 
    195192            IF( ln_zps .AND. .NOT. ln_isfcav)                               & 
    … …  
    203200                                  ua(:,:,:) = 0.e0             ! set dynamics trends to zero 
    204201                                  va(:,:,:) = 0.e0 
    205           IF(  lk_asminc .AND. ln_asmiau .AND. & 
     202          IF(  ln_asmiau .AND. & 
    206203             & ln_dyninc       )  CALL dyn_asm_inc  ( kstp )   ! apply dynamics assimilation increment 
    207204          IF( ln_neptsimp )       CALL dyn_nept_cor ( kstp )   ! subtract Neptune velocities (simplified) 
    … …  
    251248                             tsa(:,:,:,:) = 0.e0            ! set tracer trends to zero 
    252249 
    253       IF(  lk_asminc .AND. ln_asmiau .AND. & 
     250      IF(  ln_asmiau .AND. & 
    254251         & ln_trainc     )   CALL tra_asm_inc( kstp )       ! apply tracer assimilation increment 
    255252                             CALL tra_sbc    ( kstp )       ! surface boundary condition 
    … …  
    273270         IF( ln_zdfnpc   )   CALL tra_npc( kstp )                ! update after fields by non-penetrative convection 
    274271                             CALL tra_nxt( kstp )                ! tracer fields at next time step 
     272            IF( ln_sto_eos ) CALL sto_pts( tsn )                 ! Random T/S fluctuations 
    275273                             CALL eos    ( tsa, rhd, rhop, fsdept_n(:,:,:) )  ! Time-filtered in situ density for hpg computation 
    276274            IF( ln_zps .AND. .NOT. ln_isfcav)                                & 
    … …  
    283281      ELSE                                                  ! centered hpg  (eos then time stepping) 
    284282         IF ( .NOT. lk_dynspg_ts ) THEN                     ! eos already called in time-split case 
     283            IF( ln_sto_eos ) CALL sto_pts( tsn )    ! Random T/S fluctuations 
    285284                             CALL eos    ( tsn, rhd, rhop, fsdept_n(:,:,:) )  ! now in situ density for hpg computation 
    286285         IF( ln_zps .AND. .NOT. ln_isfcav)                                   & 
    … …  
    315314                               va(:,:,:) = 0.e0 
    316315 
    317         IF(  lk_asminc .AND. ln_asmiau .AND. & 
     316        IF(  ln_asmiau .AND. & 
    318317           & ln_dyninc      )  CALL dyn_asm_inc( kstp )     ! apply dynamics assimilation increment 
    319318        IF( ln_bkgwri )        CALL asm_bkg_wri( kstp )     ! output background fields 
    … …  
    336335                               CALL ssh_swp( kstp )         ! swap of sea surface height 
    337336      IF( lk_vvl           )   CALL dom_vvl_sf_swp( kstp )  ! swap of vertical scale factors 
    338       ! 
    339       IF( lrst_oce         )   CALL rst_write( kstp )       ! write output ocean restart file 
    340       IF( ln_sto_eos       )   CALL sto_rst_write( kstp )   ! write restart file for stochastic parameters 
    341  
    342 #if defined key_agrif 
    343       !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    344       ! AGRIF 
    345       !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<       
    346                                CALL Agrif_Integrate_ChildGrids( stp )   
    347  
    348       IF ( Agrif_NbStepint().EQ.0 ) THEN 
    349                                CALL Agrif_Update_Tra()      ! Update active tracers 
    350                                CALL Agrif_Update_Dyn()      ! Update momentum 
    351       ENDIF 
    352 #endif 
     337 
    353338      IF( ln_diahsb        )   CALL dia_hsb( kstp )         ! - ML - global conservation diagnostics 
    354339      IF( lk_diaobs  )         CALL dia_obs( kstp )         ! obs-minus-model (assimilation) diagnostics (call after dynamics update) 
    355340 
    356341      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    357       ! Control 
     342      ! Control and restarts 
    358343      !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 
    359344                               CALL stp_ctl( kstp, indic ) 
    … …  
    367352         IF( lwm.AND.numoni /= -1 ) CALL FLUSH    ( numoni )     ! flush output namelist ice 
    368353      ENDIF 
     354      IF( lrst_oce         )   CALL rst_write    ( kstp )   ! write output ocean restart file 
    369355 
    370356      !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 
    … …  
    381367      ! 
    382368      IF( nn_timing == 1 .AND.  kstp == nit000  )   CALL timing_reset 
    383       !      
    384369      ! 
    385370   END SUBROUTINE stp 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/step_oce.F90

    r6617 r6625  
    112112#if defined key_agrif 
    113113   USE agrif_opa_sponge ! Momemtum and tracers sponges 
    114    USE agrif_opa_update ! Update (2-way nesting) 
    115114#endif 
    116115#if defined key_top 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/OPA_SRC/stpctl.F90

    r6617 r6625  
    1717   USE dom_oce         ! ocean space and time domain variables  
    1818   USE sol_oce         ! ocean space and time domain variables  
    19    USE sbc_oce         ! surface boundary conditions variables 
    2019   USE in_out_manager  ! I/O manager 
    2120   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    … …  
    2322   USE dynspg_oce      ! pressure gradient schemes  
    2423   USE c1d             ! 1D vertical configuration 
    25  
    2624 
    2725   IMPLICIT NONE 
    … …  
    5452      INTEGER, INTENT( inout ) ::   kindic  ! indicator of solver convergence 
    5553      !! 
    56       CHARACTER(len = 32) ::        clfname ! time stepping output file name 
    5754      INTEGER  ::   ji, jj, jk              ! dummy loop indices 
    5855      INTEGER  ::   ii, ij, ik              ! temporary integers 
    … …  
    6663         WRITE(numout,*) 'stp_ctl : time-stepping control' 
    6764         WRITE(numout,*) '~~~~~~~' 
    68          ! open time.step file with special treatment for SAS 
    69          IF ( nn_components == jp_iam_sas ) THEN 
    70             clfname = 'time.step.sas' 
    71          ELSE 
    72             clfname = 'time.step' 
    73          ENDIF 
    74          CALL ctl_opn( numstp, TRIM(clfname), 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
     65         ! open time.step file 
     66         CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) 
    7567      ENDIF 
    7668 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/SAS_SRC/daymod.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/SAS_SRC/nemogcm.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zbio.F90

    r6617 r6625  
    599599 
    600600   !!====================================================================== 
    601 END MODULE p2zbio 
     601END MODULE  p2zbio 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zsms.F90

    r6617 r6625  
    8484 
    8585   !!====================================================================== 
    86 END MODULE p2zsms 
     86END MODULE  p2zsms 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zbio.F90

    r6617 r6625  
    109109 
    110110   !!====================================================================== 
    111 END MODULE p4zbio 
     111END MODULE  p4zbio 
     112 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zche.F90

    r6617 r6625  
    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 
    34    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2   ! Solubilities of O2 and CO2 
     33   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemc    ! Solubilities of O2 and CO2 
     34   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   chemo2    ! Solubilities of O2 and CO2 
    3535 
    3636   REAL(wp), PUBLIC ::   atcox  = 0.20946         ! units atm 
    … …  
    7676   REAL(wp) ::   st1    =      0.14     ! constants for calculate concentrations for sulfate 
    7777   REAL(wp) ::   st2    =  1./96.062    !  (Morris & Riley 1966) 
     78   REAL(wp) ::   ks0    =    141.328  
     79   REAL(wp) ::   ks1    =  -4276.1   
     80   REAL(wp) ::   ks2    =    -23.093 
     81   REAL(wp) ::   ks3    = -13856.   
     82   REAL(wp) ::   ks4    =   324.57  
     83   REAL(wp) ::   ks5    =   -47.986 
     84   REAL(wp) ::   ks6    =  35474.  
     85   REAL(wp) ::   ks7    =   -771.54 
     86   REAL(wp) ::   ks8    =    114.723 
     87   REAL(wp) ::   ks9    =  -2698.   
     88   REAL(wp) ::   ks10   =   1776.  
     89   REAL(wp) ::   ks11   =      1. 
     90   REAL(wp) ::   ks12   =     -0.001005  
    7891 
    7992   REAL(wp) ::   ft1    =    0.000067   ! constants for calculate concentrations for fluorides 
    8093   REAL(wp) ::   ft2    = 1./18.9984    ! (Dickson & Riley 1979 ) 
     94   REAL(wp) ::   kf0    =  -12.641     
     95   REAL(wp) ::   kf1    = 1590.2     
     96   REAL(wp) ::   kf2    =    1.525     
     97   REAL(wp) ::   kf3    =    1.0      
     98   REAL(wp) ::   kf4    =   -0.001005 
     99 
     100   REAL(wp) ::   cb0    = -8966.90      ! Coeff. for 1. dissoc. of boric acid  
     101   REAL(wp) ::   cb1    = -2890.53      ! (Dickson and Goyet, 1994) 
     102   REAL(wp) ::   cb2    =   -77.942 
     103   REAL(wp) ::   cb3    =     1.728 
     104   REAL(wp) ::   cb4    =    -0.0996 
     105   REAL(wp) ::   cb5    =   148.0248 
     106   REAL(wp) ::   cb6    =   137.1942 
     107   REAL(wp) ::   cb7    =     1.62142 
     108   REAL(wp) ::   cb8    =   -24.4344 
     109   REAL(wp) ::   cb9    =   -25.085 
     110   REAL(wp) ::   cb10   =    -0.2474  
     111   REAL(wp) ::   cb11   =     0.053105 
     112 
     113   REAL(wp) ::   cw0    = -13847.26     ! Coeff. for dissoc. of water (Dickson and Riley, 1979 ) 
     114   REAL(wp) ::   cw1    =    148.9652   
     115   REAL(wp) ::   cw2    =    -23.6521 
     116   REAL(wp) ::   cw3    =    118.67  
     117   REAL(wp) ::   cw4    =     -5.977  
     118   REAL(wp) ::   cw5    =      1.0495   
     119   REAL(wp) ::   cw6    =     -0.01615 
    81120 
    82121   !                                    ! volumetric solubility constants for o2 in ml/L   
    … …  
    161200         DO ji = 1, jpi 
    162201            !                             ! SET ABSOLUTE TEMPERATURE 
    163             ztkel = tsn(ji,jj,1,jp_tem) + 273.15 
     202            ztkel = tsn(ji,jj,1,jp_tem) + 273.16 
    164203            zt    = ztkel * 0.01 
    165204            zt2   = zt * zt 
    … …  
    170209            !                             !     AND FOR THE ATMOSPHERE FOR NON IDEAL GAS 
    171210            zcek1 = ca0 + ca1 / zt + ca2 * zlogt + ca3 * zt2 + zsal * ( ca4 + ca5 * zt + ca6 * zt2 ) 
     211            !                             ! LN(K0) OF SOLUBILITY OF O2 and N2 in ml/L (EQ. 8, GARCIA AND GORDON, 1992) 
     212            ztgg  = LOG( ( 298.15 - tsn(ji,jj,1,jp_tem) ) / ztkel )  ! Set the GORDON & GARCIA scaled temperature 
     213            ztgg2 = ztgg  * ztgg 
     214            ztgg3 = ztgg2 * ztgg 
     215            ztgg4 = ztgg3 * ztgg 
     216            ztgg5 = ztgg4 * ztgg 
     217            zoxy  = ox0 + ox1 * ztgg + ox2 * ztgg2 + ox3 * ztgg3 + ox4 * ztgg4 + ox5 * ztgg5   & 
     218                   + zsal * ( ox6 + ox7 * ztgg + ox8 * ztgg2 + ox9 * ztgg3 ) +  ox10 * zsal2 
     219 
    172220            !                             ! SET SOLUBILITIES OF O2 AND CO2  
    173             chemc(ji,jj) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
     221            chemc(ji,jj,1) = EXP( zcek1 ) * 1.e-6 * rhop(ji,jj,1) / 1000.  ! mol/(L uatm) 
     222            chemc(ji,jj,2) = ( EXP( zoxy  ) * o2atm ) * oxyco              ! mol/(L atm) 
    174223            ! 
    175224         END DO 
    … …  
    184233!CDIR NOVERRCHK 
    185234            DO ji = 1, jpi 
    186               ztkel = tsn(ji,jj,jk,jp_tem) + 273.15 
     235              ztkel = tsn(ji,jj,jk,jp_tem) + 273.16 
    187236              zsal  = tsn(ji,jj,jk,jp_sal) + ( 1.- tmask(ji,jj,jk) ) * 35. 
    188237              zsal2 = zsal * zsal 
    … …  
    214263 
    215264               ! SET ABSOLUTE TEMPERATURE 
    216                ztkel   = tsn(ji,jj,jk,jp_tem) + 273.15 
     265               ztkel   = tsn(ji,jj,jk,jp_tem) + 273.16 
    217266               zsal    = tsn(ji,jj,jk,jp_sal) + ( 1.-tmask(ji,jj,jk) ) * 35. 
    218267               zsqrt  = SQRT( zsal ) 
    … …  
    235284 
    236285               ! DISSOCIATION CONSTANT FOR SULFATES on free H scale (Dickson 1990) 
    237                zcks    = EXP(-4276.1 * ztr + 141.328 - 23.093 * zlogt         & 
    238                &         + (-13856. * ztr + 324.57 - 47.986 * zlogt) * zisqrt & 
    239                &         + (35474. * ztr - 771.54 + 114.723 * zlogt) * zis    & 
    240                &         - 2698. * ztr * zis**1.5 + 1776.* ztr * zis2         & 
    241                &         + LOG(1.0 - 0.001005 * zsal)) 
    242                ! 
    243                aphscale(ji,jj,jk) = ( 1. + zst / zcks ) 
     286               zcks    = EXP(  ks1 * ztr + ks0 + ks2 * zlogt                           & 
     287                  &                     + ( ks3 * ztr + ks4 + ks5 * zlogt ) * zisqrt   & 
     288                  &                     + ( ks6 * ztr + ks7 + ks8 * zlogt ) * zis      & 
     289                  &                     + ks9 * ztr * zis * zisqrt + ks10 * ztr *zis2 + LOG( ks11 + ks12 *zsal )  ) 
    244290 
    245291               ! DISSOCIATION CONSTANT FOR FLUORIDES on free H scale (Dickson and Riley 79) 
    246                zckf    = EXP( 1590.2*ztr - 12.641 + 1.525*zisqrt   & 
    247                &         + LOG(1.0d0 - 0.001005d0*zsal)            & 
    248                &         + LOG(1.0d0 + zst/zcks)) 
     292               zckf    = EXP(  kf1 * ztr + kf0 + kf2 * zisqrt + LOG( kf3 + kf4 * zsal )  ) 
    249293 
    250294               ! DISSOCIATION CONSTANT FOR CARBONATE AND BORATE 
    251                zckb=  (-8966.90 - 2890.53*zsqrt - 77.942*zsal        & 
    252                &      + 1.728*zsal15 - 0.0996*zsal*zsal)*ztr         & 
    253                &      + (148.0248 + 137.1942*zsqrt + 1.62142*zsal)   & 
    254                &      + (-24.4344 - 25.085*zsqrt - 0.2474*zsal)      &  
    255                &      * zlogt + 0.053105*zsqrt*ztkel 
    256  
     295               zckb    = ( cb0 + cb1 * zsqrt + cb2  * zsal + cb3 * zsal15 + cb4 * zsal * zsal ) * ztr   & 
     296                  &    + ( cb5 + cb6 * zsqrt + cb7  * zsal )                                            & 
     297                  &    + ( cb8 + cb9 * zsqrt + cb10 * zsal ) * zlogt + cb11 * zsqrt * ztkel             & 
     298                  &    + LOG(  ( 1.+ zst / zcks + zft / zckf ) / ( 1.+ zst / zcks )  ) 
    257299 
    258300               zck1    = c10 * ztr + c11 + c12 * zlogt + c13 * zsal + c14 * zsal * zsal 
    … …  
    260302 
    261303               ! PKW (H2O) (DICKSON AND RILEY, 1979) 
    262                zckw = -13847.26*ztr + 148.9652 - 23.6521 * zlogt    &  
    263                &     + (118.67*ztr - 5.977 + 1.0495 * zlogt)        & 
    264                &     * zsqrt - 0.01615 * zsal 
     304               zckw    = cw0 * ztr + cw1 + cw2 * zlogt + ( cw3 * ztr + cw4 + cw5 * zlogt ) * zsqrt + cw6 * zsal 
     305 
    265306 
    266307               ! APPARENT SOLUBILITY PRODUCT K'SP OF CALCITE IN SEAWATER 
    … …  
    337378      !!                     ***  ROUTINE p4z_che_alloc  *** 
    338379      !!---------------------------------------------------------------------- 
    339       ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj), chemo2(jpi,jpj,jpk),   & 
    340       &         STAT=p4z_che_alloc ) 
     380      ALLOCATE( sio3eq(jpi,jpj,jpk), fekeq(jpi,jpj,jpk), chemc(jpi,jpj,2), chemo2(jpi,jpj,jpk), STAT=p4z_che_alloc ) 
    341381      ! 
    342382      IF( p4z_che_alloc /= 0 )   CALL ctl_warn('p4z_che_alloc : failed to allocate arrays.') 
    … …  
    356396 
    357397   !!====================================================================== 
    358 END MODULE p4zche 
     398END MODULE  p4zche 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zflx.F90

    r6617 r6625  
    8484      ! 
    8585      INTEGER  ::   ji, jj, jm, iind, iindm1 
    86       REAL(wp) ::   ztc, ztc2, ztc3, ztc4, zws, zkgwan 
     86      REAL(wp) ::   ztc, ztc2, ztc3, zws, zkgwan 
    8787      REAL(wp) ::   zfld, zflu, zfld16, zflu16, zfact 
    8888      REAL(wp) ::   zph, zah2, zbot, zdic, zalk, zsch_o2, zalka, zsch_co2 
    … …  
    135135 
    136136               ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    137                zalk  = zalka - (  akw3(ji,jj,1) / zph - zph / aphscale(ji,jj,1)    & 
    138                &       + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
     137               zalk  = zalka - (  akw3(ji,jj,1) / zph - zph + zbot / ( 1.+ zph / akb3(ji,jj,1) )  ) 
    139138 
    140139               ! CALCULATE [H+] AND [H2CO3] 
    … …  
    163162            ztc2 = ztc * ztc 
    164163            ztc3 = ztc * ztc2  
    165             ztc4 = ztc2 * ztc2  
    166164            ! Compute the schmidt Number both O2 and CO2 
    167             zsch_co2 = 2116.8 - 136.25 * ztc + 4.7353 * ztc2 - 0.092307 * ztc3 + 0.0007555 * ztc4 
    168             zsch_o2  = 1920.4 - 135.6  * ztc + 5.2122 * ztc2 - 0.109390 * ztc3 + 0.0009377 * ztc4 
     165            zsch_co2 = 2073.1 - 125.62 * ztc + 3.6276 * ztc2 - 0.043126 * ztc3 
     166            zsch_o2  = 1953.4 - 128.0  * ztc + 3.9918 * ztc2 - 0.050091 * ztc3 
    169167            !  wind speed  
    170168            zws  = wndm(ji,jj) * wndm(ji,jj) 
    171169            ! Compute the piston velocity for O2 and CO2 
    172             zkgwan = 0.251 * zws 
     170            zkgwan = 0.3 * zws  + 2.5 * ( 0.5246 + 0.016256 * ztc + 0.00049946  * ztc2 ) 
    173171            zkgwan = zkgwan * xconv * ( 1.- fr_i(ji,jj) ) * tmask(ji,jj,1) 
    174172# if defined key_degrad 
    … …  
    184182         DO ji = 1, jpi 
    185183            ! 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) 
     184            zfld = satmco2(ji,jj) * patm(ji,jj) * tmask(ji,jj,1) * chemc(ji,jj,1) * zkgco2(ji,jj)   ! (mol/L) * (m/s) 
    187185            zflu = zh2co3(ji,jj) * tmask(ji,jj,1) * zkgco2(ji,jj)                                   ! (mol/L) (m/s) ? 
    188186            oce_co2(ji,jj) = ( zfld - zflu ) * rfact2 * e1e2t(ji,jj) * tmask(ji,jj,1) * 1000. 
    … …  
    191189 
    192190            ! Compute O2 flux  
    193             zfld16 = patm(ji,jj) * chemo2(ji,jj,1) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
     191            zfld16 = atcox * patm(ji,jj) * chemc(ji,jj,2) * tmask(ji,jj,1) * zkgo2(ji,jj)          ! (mol/L) * (m/s) 
    194192            zflu16 = trb(ji,jj,1,jpoxy) * tmask(ji,jj,1) * zkgo2(ji,jj) 
    195193            zoflx(ji,jj) = zfld16 - zflu16 
    … …  
    224222         ENDIF 
    225223         IF( iom_use( "Dpco2" ) ) THEN 
    226            zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1) 
     224           zw2d(:,:) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1) 
    227225           CALL iom_put( "Dpco2" ,  zw2d ) 
    228226         ENDIF 
    229227         IF( iom_use( "Dpo2" ) )  THEN 
    230            zw2d(:,:) = ( atcox * patm(:,:) - atcox * trn(:,:,1,jpoxy) / ( chemo2(:,:,1) + rtrn ) ) * tmask(:,:,1) 
     228           zw2d(:,:) = ( atcox * patm(:,:) - trb(:,:,1,jpoxy) / ( chemc(:,:,2) + rtrn ) ) * tmask(:,:,1) 
    231229           CALL iom_put( "Dpo2"  , zw2d ) 
    232230         ENDIF 
    … …  
    240238            trc2d(:,:,jp_pcs0_2d + 1) = zoflx(:,:) * 1000 * tmask(:,:,1)  
    241239            trc2d(:,:,jp_pcs0_2d + 2) = zkgco2(:,:) * tmask(:,:,1)  
    242             trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:) + rtrn ) ) * tmask(:,:,1)  
     240            trc2d(:,:,jp_pcs0_2d + 3) = ( satmco2(:,:) * patm(:,:) - zh2co3(:,:) / ( chemc(:,:,1) + rtrn ) ) * tmask(:,:,1)  
    243241         ENDIF 
    244242      ENDIF 
    … …  
    402400 
    403401   !!====================================================================== 
    404 END MODULE p4zflx 
     402END MODULE  p4zflx 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zint.F90

    r6617 r6625  
    8181 
    8282   !!====================================================================== 
    83 END MODULE p4zint 
     83END MODULE  p4zint 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlim.F90

    r6617 r6625  
    265265 
    266266   !!====================================================================== 
    267 END MODULE p4zlim 
     267END MODULE  p4zlim 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zlys.F90

    r6617 r6625  
    9191                  zalka = trb(ji,jj,jk,jptal) / zfact 
    9292                  ! CALCULATE [ALK]([CO3--], [HCO3-]) 
    93                   zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph / ( aphscale(ji,jj,jk) + rtrn )  & 
    94                   &       + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
     93                  zalk  = zalka - ( akw3(ji,jj,jk) / zph - zph + borat(ji,jj,jk) / ( 1. + zph / akb3(ji,jj,jk) ) ) 
    9594                  ! CALCULATE [H+] and [CO3--] 
    9695                  zaldi = zdic - zalk 
    … …  
    153152         IF( iom_use( "DCAL"   ) ) CALL iom_put( "DCAL"  , zcaldiss(:,:,:) * 1.e+3 * rfact2r   * tmask(:,:,:) ) 
    154153      ELSE 
    155          IF( ln_diatrc ) THEN 
    156             trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
    157             trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
    158             trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
    159          ENDIF 
     154         trc3d(:,:,:,jp_pcs0_3d    ) = -1. * LOG10( hi(:,:,:) ) * tmask(:,:,:) 
     155         trc3d(:,:,:,jp_pcs0_3d + 1) = zco3(:,:,:)              * tmask(:,:,:) 
     156         trc3d(:,:,:,jp_pcs0_3d + 2) = aksp(:,:,:) / calcon     * tmask(:,:,:) 
    160157      ENDIF 
    161158      ! 
    … …  
    226223#endif  
    227224   !!====================================================================== 
    228 END MODULE p4zlys 
     225END MODULE  p4zlys 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmeso.F90

    r6617 r6625  
    340340 
    341341   !!====================================================================== 
    342 END MODULE p4zmeso 
     342END MODULE  p4zmeso 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmicro.F90

    r6617 r6625  
    273273 
    274274   !!====================================================================== 
    275 END MODULE p4zmicro 
     275END MODULE  p4zmicro 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zmort.F90

    r6617 r6625  
    277277 
    278278   !!====================================================================== 
    279 END MODULE p4zmort 
     279END MODULE  p4zmort 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zopt.F90

    r6617 r6625  
    439439 
    440440   !!====================================================================== 
    441 END MODULE p4zopt 
     441END MODULE  p4zopt 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zprod.F90

    r6617 r6625  
    629629 
    630630   !!====================================================================== 
    631 END MODULE p4zprod 
     631END MODULE  p4zprod 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsbc.F90

    r6617 r6625  
    519519 
    520520   !!====================================================================== 
    521 END MODULE p4zsbc 
     521END MODULE  p4zsbc 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsed.F90

    r6617 r6625  
    7272      CHARACTER (len=25) :: charout 
    7373      REAL(wp), POINTER, DIMENSION(:,:  ) :: zpdep, zsidep, zwork1, zwork2, zwork3 
    74       REAL(wp), POINTER, DIMENSION(:,:)   :: zsedcal, zsedsi, zsedc 
    7574      REAL(wp), POINTER, DIMENSION(:,:  ) :: zdenit2d, zironice, zbureff 
    7675      REAL(wp), POINTER, DIMENSION(:,:  ) :: zwsbio3, zwsbio4, zwscal 
    … …  
    8483      ! Allocate temporary workspace 
    8584      CALL wrk_alloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
    86       CALL wrk_alloc( jpi, jpj, zsedcal,  zsedsi, zsedc ) 
    8785      CALL wrk_alloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    8886      CALL wrk_alloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    9391      zwork2  (:,:) = 0.e0 
    9492      zwork3  (:,:) = 0.e0 
    95       zsedsi   (:,:) = 0.e0 
    96       zsedcal  (:,:) = 0.e0 
    97       zsedc    (:,:) = 0.e0 
    9893 
    9994      ! Iron input/uptake due to sea ice : Crude parameterization based on Lancelot et al. 
    … …  
    303298            tra(ji,jj,ikt,jptal) =  tra(ji,jj,ikt,jptal) + zcaloss * zrivalk * 2.0 
    304299            tra(ji,jj,ikt,jpdic) =  tra(ji,jj,ikt,jpdic) + zcaloss * zrivalk 
    305             zsedcal(ji,jj) = (1.0 - zrivalk) * zcaloss / zdep 
    306             zsedsi (ji,jj) = (1.0 - zrivsil) * zsiloss / zdep 
    307300#endif 
    308301         END DO 
    … …  
    343336            tra(ji,jj,ikt,jptal) = tra(ji,jj,ikt,jptal) + rno3 * (zolimit + (1.+rdenit) * (zpdenit + zdenitt) ) 
    344337            tra(ji,jj,ikt,jpdic) = tra(ji,jj,ikt,jpdic) + zpdenit + zolimit + zdenitt 
    345             sdenit(ji,jj) = rdenit * zpdenit / zdep 
    346             zsedc(ji,jj)   = (1. - zrivno3) * zwstpoc / zdep 
     338            sdenit(ji,jj) = rdenit * zpdenit * fse3t(ji,jj,ikt) 
    347339#endif 
    348340         END DO 
    … …  
    400392               CALL iom_put( "INTNFIX" , zwork1 )  
    401393            ENDIF 
    402             IF( iom_use("SedCal" ) ) CALL iom_put( "SedCal", zsedcal(:,:) * 1.e+3 ) 
    403             IF( iom_use("SedSi" ) )  CALL iom_put( "SedSi",  zsedsi (:,:) * 1.e+3 ) 
    404             IF( iom_use("SedC" ) )   CALL iom_put( "SedC",   zsedc  (:,:) * 1.e+3 ) 
    405             IF( iom_use("Sdenit" ) ) CALL iom_put( "Sdenit", sdenit (:,:) * 1.e+3 * rno3 ) 
    406394         ENDIF 
    407395      ELSE 
    … …  
    417405      ! 
    418406      CALL wrk_dealloc( jpi, jpj, zdenit2d, zwork1, zwork2, zwork3, zbureff ) 
    419       CALL wrk_dealloc( jpi, jpj, zsedcal , zsedsi, zsedc ) 
    420407      CALL wrk_dealloc( jpi, jpj, zwsbio3, zwsbio4, zwscal ) 
    421408      CALL wrk_dealloc( jpi, jpj, jpk, zsoufer ) 
    … …  
    449436 
    450437   !!====================================================================== 
    451 END MODULE p4zsed 
     438END MODULE  p4zsed 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsink.F90

    r6617 r6625  
    913913 
    914914   !!====================================================================== 
    915 END MODULE p4zsink 
     915END MODULE  p4zsink 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/P4Z/p4zsms.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/sms_pisces.F90

    r6617 r6625  
    101101   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   hi         !: ??? 
    102102   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   excess     !: ??? 
    103    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   aphscale   !:  
    104  
    105103 
    106104   !!* Temperature dependancy of SMS terms 
    … …  
    156154         &      ak23(jpi,jpj,jpk)    , aksp  (jpi,jpj,jpk) ,       & 
    157155         &      akw3(jpi,jpj,jpk)    , borat (jpi,jpj,jpk) ,       & 
    158          &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,       & 
    159          &      aphscale(jpi,jpj,jpk),                           STAT=ierr(4) ) 
     156         &      hi  (jpi,jpj,jpk)    , excess(jpi,jpj,jpk) ,     STAT=ierr(4) ) 
    160157         ! 
    161158      !* Temperature dependancy of SMS terms 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/trcice_pisces.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/PISCES/trcini_pisces.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trcdmp.F90

    r6617 r6625  
    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) )   ! read tracer data at nit000 
     110               ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
    111111 
    112112               SELECT CASE ( nn_zdmp_tr ) 
    … …  
    187187      INTEGER :: ji , jj, jk, jn, jl, jc                     ! dummy loop indicesa 
    188188      INTEGER :: isrow                                      ! local index 
     189      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta       ! 3D  workspace 
    189190 
    190191      !!---------------------------------------------------------------------- 
    … …  
    277278         IF(lwp)  WRITE(numout,*) 
    278279         ! 
     280         CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )   ! Memory allocation 
     281         ! 
    279282         DO jn = 1, jptra 
    280283            IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    281284                jl = n_trc_index(jn) 
    282                 CALL trc_dta( kt, sf_trcdta(jl) )   ! read tracer data at nit000 
     285                CALL trc_dta( kt, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
     286                ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
    283287                DO jc = 1, npncts 
    284288                   DO jk = 1, jpkm1 
    285289                      DO jj = nctsj1(jc), nctsj2(jc) 
    286290                         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) 
     291                            trn(ji,jj,jk,jn) = ztrcdta(ji,jj,jk) * tmask(ji,jj,jk) 
    288292                            trb(ji,jj,jk,jn) = trn(ji,jj,jk,jn) 
    289293                         ENDDO 
    … …  
    293297             ENDIF 
    294298          ENDDO 
    295           ! 
     299          CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
    296300      ENDIF 
    297301      ! 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trcldf.F90

    r6617 r6625  
    5656      INTEGER, INTENT( in ) ::   kt   ! ocean time-step index 
    5757      !! 
    58       INTEGER            :: ji, jj, jk, jn 
    59       REAL(wp)           :: zdep 
     58      INTEGER            :: jn 
    6059      CHARACTER (len=22) :: charout 
    6160      REAL(wp), POINTER, DIMENSION(:,:,:,:) ::   ztrtrd 
    … …  
    6766 
    6867      rldf = rldf_rat 
    69       ! 
    70       r_fact_lap(:,:,:) = 1. 
    71       DO jk= 1, jpk 
    72          DO jj = 1, jpj 
    73             DO ji = 1, jpi 
    74                IF( fsdept(ji,jj,jk) > 200. .AND. gphit(ji,jj) < 5. .AND. gphit(ji,jj) > -5. ) THEN 
    75                   zdep = MAX( fsdept(ji,jj,jk) - 1000., 0. ) / 1000. 
    76                   r_fact_lap(ji,jj,jk) = MAX( 1., rn_fact_lap * EXP( -zdep ) ) 
    77                ENDIF 
    78             END DO 
    79          END DO 
    80       END DO 
    81       ! 
     68 
    8269      IF( l_trdtrc )  THEN 
    8370         CALL wrk_alloc( jpi, jpj, jpk, jptra, ztrtrd ) 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trcnam_trp.F90

    r6617 r6625  
    4040   REAL(wp), PUBLIC ::   rn_ahtrc_0          !: diffusivity coefficient for passive tracer (m2/s) 
    4141   REAL(wp), PUBLIC ::   rn_ahtrb_0          !: background diffusivity coefficient for passive tracer (m2/s) 
    42    REAL(wp), PUBLIC ::   rn_fact_lap         !: Enhanced zonal diffusivity coefficent in the equatorial domain 
    4342 
    4443   !                                        !!: ** Treatment of Negative concentrations ( nam_trcrad ) 
    … …  
    7574      NAMELIST/namtrc_ldf/ ln_trcldf_lap  ,     & 
    7675         &                 ln_trcldf_bilap, ln_trcldf_level,     & 
    77          &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0,   & 
    78          &                 rn_fact_lap 
    79  
     76         &                 ln_trcldf_hor  , ln_trcldf_iso  , rn_ahtrc_0, rn_ahtrb_0 
    8077      NAMELIST/namtrc_zdf/ ln_trczdf_exp  , nn_trczdf_exp 
    8178      NAMELIST/namtrc_rad/ ln_trcrad 
    … …  
    130127         WRITE(numout,*) '      diffusivity coefficient                                 rn_ahtrc_0 = ', rn_ahtrc_0 
    131128         WRITE(numout,*) '      background hor. diffusivity                             rn_ahtrb_0 = ', rn_ahtrb_0 
    132          WRITE(numout,*) '      enhanced zonal diffusivity                             rn_fact_lap = ', rn_fact_lap 
    133129      ENDIF 
    134130 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trcnxt.F90

    r6617 r6625  
    102102      ENDIF 
    103103 
    104 #if defined key_agrif 
    105       CALL Agrif_trc                   ! AGRIF zoom boundaries 
    106 #endif 
    107104      ! Update after tracer on domain lateral boundaries 
    108105      DO jn = 1, jptra 
    … …  
    113110#if defined key_bdy 
    114111!!      CALL bdy_trc( kt )               ! BDY open boundaries 
     112#endif 
     113#if defined key_agrif 
     114      CALL Agrif_trc                   ! AGRIF zoom boundaries 
    115115#endif 
    116116 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trcsbc.F90

    r6617 r6625  
    170170            END DO 
    171171         ENDIF 
    172          ! 
    173          CALL lbc_lnk( sbc_trc(:,:,jn), 'T', 1. ) 
    174172         !                                       Concentration dilution effect on tracers due to evaporation & precipitation  
    175173         DO jj = 2, jpj 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/TRP/trctrp.F90

    r6617 r6625  
    6767         IF( lk_trabbl )        CALL trc_bbl( kstp )            ! advective (and/or diffusive) bottom boundary layer scheme 
    6868         IF( ln_trcdmp )        CALL trc_dmp( kstp )            ! internal damping trends 
     69         IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    6970                                CALL trc_adv( kstp )            ! horizontal & vertical advection  
    7071                                CALL trc_ldf( kstp )            ! lateral mixing 
    … …  
    7778                                CALL trc_nxt( kstp )            ! tracer fields at next time step      
    7879         IF( ln_trcrad )        CALL trc_rad( kstp )            ! Correct artificial negative concentrations 
    79          IF( ln_trcdmp_clo )    CALL trc_dmp_clo( kstp )        ! internal damping trends on closed seas only 
    8080 
    8181#if defined key_agrif 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/oce_trc.F90

    r6617 r6625  
    116116   USE ldftra_oce , ONLY :  aeiw     =>   aeiw        !: eddy induced velocity coef. at w-points (m2/s)  
    117117   USE ldftra_oce , ONLY :  lk_traldf_eiv  =>  lk_traldf_eiv     !: eddy induced velocity flag 
    118    USE ldftra_oce , ONLY :  r_fact_lap     =>  r_fact_lap        !: enhanced zonal diffusivity coefficient 
    119118 
    120119   !* vertical diffusion * 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/trcdta.F90

    r6617 r6625  
    151151 
    152152 
    153    SUBROUTINE trc_dta( kt, sf_dta ) 
     153   SUBROUTINE trc_dta( kt, sf_dta, zrf_trfac ) 
    154154      !!---------------------------------------------------------------------- 
    155155      !!                   ***  ROUTINE trc_dta  *** 
    … …  
    165165      INTEGER                     , INTENT(in   ) ::   kt     ! ocean time-step 
    166166      TYPE(FLD), DIMENSION(1)   , INTENT(inout) ::   sf_dta     ! array of information on the field to read 
     167      REAL(wp)                  , INTENT(in   ) ::   zrf_trfac  ! multiplication factor 
    167168      ! 
    168169      INTEGER ::   ji, jj, jk, jl, jkk, ik    ! dummy loop indices 
    … …  
    233234         ENDIF 
    234235         ! 
     236         sf_dta(1)%fnow(:,:,:) = sf_dta(1)%fnow(:,:,:) * zrf_trfac   !  multiplicative factor 
     237         ! 
    235238         IF( lwp .AND. kt == nit000 ) THEN 
    236239               clndta = TRIM( sf_dta(1)%clvar )  

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/trcini.F90

    r6617 r6625  
    6161      INTEGER ::   jk, jn, jl    ! dummy loop indices 
    6262      CHARACTER (len=25) :: charout 
     63      REAL(wp), POINTER, DIMENSION(:,:,:) ::  ztrcdta   ! 4D  workspace 
    6364      !!--------------------------------------------------------------------- 
    6465      ! 
    … …  
    120121        IF( ln_trcdta .AND. nb_trcdta > 0 ) THEN  ! Initialisation of tracer from a file that may also be used for damping 
    121122            ! 
     123            CALL wrk_alloc( jpi, jpj, jpk, ztrcdta )    ! Memory allocation 
     124            ! 
    122125            DO jn = 1, jptra 
    123126               IF( ln_trc_ini(jn) ) THEN      ! update passive tracers arrays with input data read from file 
    124127                  jl = n_trc_index(jn)  
    125                   CALL trc_dta( nit000, sf_trcdta(jl) )   ! read tracer data at nit000 
    126                   trn(:,:,:,jn) = sf_trcdta(jl)%fnow(:,:,:) * tmask(:,:,:) * rf_trfac(jl) 
    127                   ! 
     128                  CALL trc_dta( nit000, sf_trcdta(jl),rf_trfac(jl) )   ! read tracer data at nit000 
     129                  ztrcdta(:,:,:) = sf_trcdta(jl)%fnow(:,:,:) 
     130                  trn(:,:,:,jn) = ztrcdta(:,:,:) * tmask(:,:,:)   
    128131                  IF( .NOT.ln_trcdmp .AND. .NOT.ln_trcdmp_clo ) THEN      !== deallocate data structure   ==! 
    129132                     !                                                    (data used only for initialisation) 
    … …  
    135138               ENDIF 
    136139            ENDDO 
    137             ! 
     140            CALL wrk_dealloc( jpi, jpj, jpk, ztrcdta ) 
    138141        ENDIF 
    139142        ! 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/trcnam.F90

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

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/trcsms.F90

    r6617 r6625  
    7575 
    7676   !!====================================================================== 
    77 END MODULE trcsms 
     77END MODULE  trcsms 

  • branches/UKMO/dev_r5518_v3.4_asm_nemovar_community/NEMOGCM/NEMO/TOP_SRC/trcstp.F90

    r6617 r6625  
    3232   REAL(wp), DIMENSION(:,:,:), SAVE, ALLOCATABLE ::   qsr_arr ! save qsr during TOP time-step 
    3333   REAL(wp) :: rdt_sampl 
    34    INTEGER  :: nb_rec_per_day 
     34   INTEGER  :: nb_rec_per_days 
    3535   INTEGER  :: isecfst, iseclast 
    3636   LOGICAL  :: llnew 
    … …  
    123123      !!               of diurnal cycle 
    124124      !! 
    125       !! ** Method  : store in TOP the qsr every hour ( or every time-step if the latter  
     125      !! ** Method  : store in TOP the qsr every hour ( or every time-step the latter  
    126126      !!              is greater than 1 hour ) and then, compute the  mean with  
    127127      !!              a moving average over 24 hours.  
    … …  
    134134         IF( ln_cpl )  THEN   
    135135            rdt_sampl = 86400. / ncpl_qsr_freq 
    136             nb_rec_per_day = ncpl_qsr_freq 
     136            nb_rec_per_days = ncpl_qsr_freq 
    137137         ELSE   
    138138            rdt_sampl = MAX( 3600., rdt * nn_dttrc ) 
    139             nb_rec_per_day = INT( 86400 / rdt_sampl ) 
     139            nb_rec_per_days = INT( 86400 / rdt_sampl ) 
    140140         ENDIF 
    141141         ! 
    142142         IF( lwp ) THEN 
    143143            WRITE(numout,*)  
    144             WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_day 
     144            WRITE(numout,*) ' Sampling frequency dt = ', rdt_sampl, 's','   Number of sampling per day  nrec = ', nb_rec_per_days 
    145145            WRITE(numout,*)  
    146146         ENDIF 
    147147         ! 
    148          !                                            !* 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' 
    151             CALL iom_get( numrtr, jpdom_autoglo, 'qsr_mean', qsr_mean )   !  A mean of qsr 
    152          ELSE                                         !* no restart: set from nit000 values 
    153             IF(lwp) WRITE(numout,*) 'trc_qsr_mean:   qsr_mean set to nit000 values' 
    154             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(:,:) 
     148         ALLOCATE( qsr_arr(jpi,jpj,nb_rec_per_days ) ) 
     149         DO jn = 1, nb_rec_per_days 
     150            qsr_arr(:,:,jn) = qsr(:,:) 
    160151         ENDDO 
     152         qsr_mean(:,:) = qsr(:,:) 
    161153         ! 
    162154         isecfst  = nsec_year + nsec1jan000   !   number of seconds between Jan. 1st 00h of nit000 year and the middle of time step 
    … …  
    171163             &                      ' time = ', (iseclast+rdt*nn_dttrc/2.)/3600.,'hours ' 
    172164          isecfst = iseclast 
    173           DO jn = 1, nb_rec_per_day - 1 
     165          DO jn = 1, nb_rec_per_days - 1 
    174166             qsr_arr(:,:,jn) = qsr_arr(:,:,jn+1) 
    175167          ENDDO 
    176           qsr_arr (:,:,nb_rec_per_day) = qsr(:,:) 
    177           qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_day 
     168          qsr_arr (:,:,nb_rec_per_days) = qsr(:,:) 
     169          qsr_mean(:,:                ) = SUM( qsr_arr(:,:,:), 3 ) / nb_rec_per_days 
    178170      ENDIF 
    179171      ! 
    180       IF( lrst_trc ) THEN    !* Write the mean of qsr in restart file  
    181          IF(lwp) WRITE(numout,*) 
    182          IF(lwp) WRITE(numout,*) 'trc_mean_qsr : write qsr_mean in restart file  kt =', kt 
    183          IF(lwp) WRITE(numout,*) '~~~~~~~' 
    184          CALL iom_rstput( kt, nitrst, numrtw, 'qsr_mean', qsr_mean(:,:) ) 
    185       ENDIF 
    186      ! 
    187172   END SUBROUTINE trc_mean_qsr 
    188173 
Note: See TracChangeset for help on using the changeset viewer.