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 2612 for branches – NEMO

Changeset 2612 for branches


Ignore:
Timestamp:
2011-02-25T11:43:45+01:00 (13 years ago)
Author:
gm
Message:

dynamic mem: #785 ; LIM-3 case: changes required for compilation (continuation)

Location:
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3
Files:
27 edited

Legend:

Unmodified
Added
Removed

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/dom_ice.F90

    r2601 r2612  
    44   !! LIM-3 Sea Ice :   Domain  variables 
    55   !!====================================================================== 
    6    !! History :  3.0  ! 2003-08  (M. Vancoppenolle)  LIM-3 
     6   !! History :  3.0  ! 2003-08  (M. Vancoppenolle)  LIM-3 original code 
     7   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    78   !!---------------------------------------------------------------------- 
    89   USE par_ice        ! LIM-3 parameter 
    … …  
    1819   INTEGER, PUBLIC ::   njeq , njeqm1        !: j-index of the equator if it is inside the domain 
    1920 
    20    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fs2cor     !: coriolis factor 
    2121   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   fcor       !: coriolis coefficient 
    2222   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   covrai     !: sine of geographic latitude 
    … …  
    2929 
    3030   !!---------------------------------------------------------------------- 
    31    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     31   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3232   !! $Id$ 
    33    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     33   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3434   !!---------------------------------------------------------------------- 
    3535CONTAINS 
    … …  
    4242      !!------------------------------------------------------------------- 
    4343      ! 
    44       ALLOCATE( fs2cor(jpi,jpj) , fcor(jpi,jpj) ,      & 
     44      ALLOCATE( fcor(jpi,jpj)                  ,      & 
    4545         &      covrai(jpi,jpj) , area(jpi,jpj) ,      & 
    4646         &      tms   (jpi,jpj) , tmi (jpi,jpj) ,      & 
    … …  
    4949         &      wght(jpi,jpj,2,2)               , STAT = dom_ice_alloc ) 
    5050      ! 
    51       IF( dom_ice_alloc /= 0 ) THEN 
    52          CALL ctl_warn( 'dom_ice_alloc: failed to allocate arrays.' ) 
    53       END IF 
     51      IF( dom_ice_alloc /= 0 )   CALL ctl_warn( 'dom_ice_alloc: failed to allocate arrays.' ) 
    5452      ! 
    5553   END FUNCTION dom_ice_alloc 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/ice.F90

    r2601 r2612  
    55   !!===================================================================== 
    66   !! History :  3.0  ! 2008-03  (M. Vancoppenolle) original code LIM-3 
    7    !!            4.0  ! 3011-02  (G. Madec) dynamical allocation 
     7   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    88   !!---------------------------------------------------------------------- 
    99#if defined key_lim3 
    … …  
    164164   REAL(wp), PUBLIC ::   rdt_ice   !: ice time step 
    165165 
    166    !                                    !!** ice-dynamic namelist (namicedyn) ** 
    167    INTEGER , PUBLIC ::   nbiter = 1      !: number of sub-time steps for relaxation 
    168    INTEGER , PUBLIC ::   nbitdr = 250    !: maximum number of iterations for relaxation 
    169    INTEGER , PUBLIC ::   nevp   = 400    !: number of iterations for subcycling 
    170    INTEGER , PUBLIC ::   nlay_i = 5      !: number of layers in the ice 
     166   !                                          !!** ice-dynamic namelist (namicedyn) ** 
     167   INTEGER , PUBLIC ::   nbiter = 1            !: number of sub-time steps for relaxation 
     168   INTEGER , PUBLIC ::   nbitdr = 250          !: maximum number of iterations for relaxation 
     169   INTEGER , PUBLIC ::   nevp   = 400          !: number of iterations for subcycling 
     170   INTEGER , PUBLIC ::   nlay_i = 5            !: number of layers in the ice 
    171171 
    172172   !                                          !!** ice-dynamic namelist (namicedyn) ** 
    … …  
    199199   REAL(wp), PUBLIC ::   bulk_sal =  4.0_wp        !: bulk salinity (ppt) in case of constant salinity 
    200200 
    201    !                                      !!** ice-salinity namelist (namicesal) ** 
    202    INTEGER , PUBLIC ::   num_sal     = 1   !: salinity configuration used in the model 
    203    !                                       ! 1 - s constant in space and time 
    204    !                                       ! 2 - prognostic salinity (s(z,t)) 
    205    !                                       ! 3 - salinity profile, constant in time 
    206    !                                       ! 4 - salinity variations affect only ice thermodynamics 
    207    INTEGER , PUBLIC ::   sal_prof    = 1   !: salinity profile or not  
    208    INTEGER , PUBLIC ::   thcon_i_swi = 1   !: thermal conductivity: =1 Untersteiner (1964) ; =2 Pringle et al (2007) 
     201   !                                              !!** ice-salinity namelist (namicesal) ** 
     202   INTEGER , PUBLIC ::   num_sal     = 1           !: salinity configuration used in the model 
     203   !                                               ! 1 - s constant in space and time 
     204   !                                               ! 2 - prognostic salinity (s(z,t)) 
     205   !                                               ! 3 - salinity profile, constant in time 
     206   !                                               ! 4 - salinity variations affect only ice thermodynamics 
     207   INTEGER , PUBLIC ::   sal_prof    = 1           !: salinity profile or not  
     208   INTEGER , PUBLIC ::   thcon_i_swi = 1           !: thermal conductivity: =1 Untersteiner (1964) ; =2 Pringle et al (2007) 
    209209 
    210210   !                                              !!** ice-mechanical redistribution namelist (namiceitdme) 
    … …  
    225225   REAL(wp), PUBLIC ::   maxer_i_thd = 1.0e-4_wp   !: maximal tolerated error (C) for heat diffusion 
    226226 
    227    !                                           !!** ice-mechanical redistribution namelist (namiceitdme) 
    228    INTEGER , PUBLIC ::   ridge_scheme_swi = 0   !: scheme used for ice ridging 
    229    INTEGER , PUBLIC ::   raftswi          = 1   !: rafting of ice or not                         
    230    INTEGER , PUBLIC ::   partfun_swi      = 1   !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 
    231    INTEGER , PUBLIC ::   transfun_swi     = 0   !: transfer function: =0 Hibler 1980, =1 Lipscomb et al. 2007 
    232    INTEGER , PUBLIC ::   brinstren_swi    = 0   !: use brine volume to diminish ice strength 
     227   !                                              !!** ice-mechanical redistribution namelist (namiceitdme) 
     228   INTEGER , PUBLIC ::   ridge_scheme_swi = 0      !: scheme used for ice ridging 
     229   INTEGER , PUBLIC ::   raftswi          = 1      !: rafting of ice or not                         
     230   INTEGER , PUBLIC ::   partfun_swi      = 1      !: participation function: =0 Thorndike et al. (1975), =1 Lipscomb et al. (2007) 
     231   INTEGER , PUBLIC ::   transfun_swi     = 0      !: transfer function: =0 Hibler 1980, =1 Lipscomb et al. 2007 
     232   INTEGER , PUBLIC ::   brinstren_swi    = 0      !: use brine volume to diminish ice strength 
    233233 
    234234   REAL(wp), PUBLIC ::   usecc2           !:  = 1.0 / ( ecc * ecc ) 
    … …  
    309309 
    310310   !! Variables summed over all categories, or associated to all the ice in a single grid cell 
    311    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice   !: two components of the ice velocity (m/s) 
    312    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tio_u, tio_v   !: two components of the ice-ocean stress (N/m2) 
    313    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i           !: ice total volume per unit area (m) 
    314    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_s           !: snow total volume per unit area (m) 
     311   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice, v_ice   !: components of the ice velocity (m/s) 
     312   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tio_u, tio_v   !: components of the ice-ocean stress (N/m2) 
     313   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   vt_i , vt_s    !: ice and snow total volume per unit area (m) 
    315314   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   at_i           !: ice total fractional area (ice concentration) 
    316    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i          !: total open water fractional area (1-at_i) 
    317    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i           !: total ice heat content 
    318    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_s           !: total snow heat content 
     315   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ato_i          !: =1-at_i ; total open water fractional area 
     316   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   et_i , et_s    !: ice and snow total heat content 
    319317   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ot_i           !: mean age over all categories 
    320318   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   tm_i           !: mean ice temperature over all categories 
    321319   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   bv_i           !: brine volume averaged over all categories 
    322    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i          !: mean sea ice salinity averaged over all categories 
    323  
    324    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   at_i_typ   !: total area contained in each ice type 
    325    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   vt_i_typ   !: total volume contained in each ice type 
    326  
    327    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s    !: Snow temperatures (K) 
    328    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s    !: Snow ...       
    329  
    330    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   e_i_cat   !: ! go to trash 
     320   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   smt_i          !: mean sea ice salinity averaged over all categories [PSU] 
     321 
     322   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   at_i_typ     !: total area   contained in each ice type [m^2] 
     323   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   vt_i_typ     !: total volume contained in each ice type [m^3] 
     324 
     325   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_s        !: Snow temperatures [K] 
     326   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_s        !: Snow ...       
     327 
     328   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   e_i_cat    !: ! go to trash 
    331329       
    332    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i   !: Ice temperatures     [ Kelvins     ] 
    333    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i   !: Ice thermal contents [ Joules*10^9 ] 
    334    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   s_i   !: Ice salinities 
     330   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   t_i        !: ice temperatures          [K] 
     331   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   e_i        !: ice thermal contents [Giga J] 
     332   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   s_i        !: ice salinities          [PSU] 
    335333 
    336334   !!-------------------------------------------------------------------------- 
    … …  
    339337   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)     ::   sxopw, syopw, sxxopw, syyopw, sxyopw   !: open water in sea ice 
    340338   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxice, syice, sxxice, syyice, sxyice   !: ice thickness  
    341    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxsn,  sysn,  sxxsn,  syysn, sxysn    !: snow thickness 
    342    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxa,   sya,   sxxa,   syya,  sxya     !: lead fraction 
    343    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxc0,  syc0,  sxxc0,  syyc0, sxyc0    !: snow thermal content 
     339   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxsn , sysn , sxxsn , syysn , sxysn    !: snow thickness 
     340   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxa  , sya  , sxxa  , syya  , sxya     !: lead fraction 
     341   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxc0 , syc0 , sxxc0 , syyc0 , sxyc0    !: snow thermal content 
    344342   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxsal, sysal, sxxsal, syysal, sxysal   !: ice salinity 
    345343   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:)   ::   sxage, syage, sxxage, syyage, sxyage   !: ice age 
    346    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sxe ,  sye ,  sxxe ,  syye , sxye     !: ice layers heat content 
     344   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) ::   sxe  , sye  , sxxe  , syye  , sxye     !: ice layers heat content 
    347345 
    348346   !!-------------------------------------------------------------------------- 
    … …  
    377375   !!-------------------------------------------------------------------------- 
    378376   ! REMOVE 
    379    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::   ice_types      !: Vector connecting types and categories 
    380    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   ice_cat_bounds !: Matrix containing the integer upper and  
     377   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   ice_types      !: Vector connecting types and categories 
     378   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   ice_cat_bounds !: Matrix containing the integer upper and  
    381379   !                                                                       !  lower boundaries of ice thickness categories 
    382380   ! REMOVE 
    383    INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)    ::   ice_ncat_types !: nb of thickness categories in each ice type 
     381   INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   ice_ncat_types !: nb of thickness categories in each ice type 
    384382   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_max         !: Boundary of ice thickness categories in thickness space 
    385383   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:)   ::   hi_mean        !: Mean ice thickness in catgories  
    386384   ! REMOVE 
    387    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hi_max_typ     !: Boundary of ice thickness categories  
    388    !                                                                       !  in thickness space (same but specific for each ice type) 
     385   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) ::   hi_max_typ     !: Boundary of ice thickness categories in thickness space 
    389386 
    390387   !!-------------------------------------------------------------------------- 
    … …  
    406403   !!-------------------------------------------------------------------------- 
    407404   !! Check if everything down here is necessary 
    408    REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)  ::   v_newice   !: volume of ice formed in the leads 
     405   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:)   ::   v_newice   !: volume of ice formed in the leads 
    409406   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   dv_dt_thd  !: thermodynamic growth rates  
    410407   REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) ::   izero, fstroc, fhbricat 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/iceini.F90

    r2601 r2612  
    66   !! History :  3.0  ! 2008-03  (M. Vancoppenolle) LIM-3 original code 
    77   !!            3.3  ! 2010-12  (G. Madec) add call to lim_thd_init and lim_thd_sal_init 
     8   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    1314   !!   ice_init       : sea-ice model initialization 
    1415   !!---------------------------------------------------------------------- 
    15    USE phycst         ! physical constants 
    16    USE dom_oce        ! ocean domain 
    17    USE sbc_oce        ! Surface boundary condition: ocean fields 
    18    USE sbc_ice        ! Surface boundary condition: ice fields 
    19    USE par_ice        ! LIM: sea-ice parameters 
    20    USE ice            ! LIM: sea-ice variables 
    21    USE limmsh         ! LIM: mesh 
    22    USE limistate      ! LIM: initial state 
    23    USE limrst         ! LIM: restart 
    24    USE limthd         ! LIM: ice thermodynamics 
    25    USE limthd_sal     ! LIM: ice thermodynamics: salinity 
    26    USE limvar         ! LIM: variables 
    27    USE in_out_manager ! I/O manager 
    28    USE lib_mpp        ! MPP library 
     16   USE phycst           ! physical constants 
     17   USE dom_oce          ! ocean domain 
     18   USE sbc_oce          ! Surface boundary condition: ocean fields 
     19   USE sbc_ice          ! Surface boundary condition: ice   fields 
     20   USE ice              ! LIM variables 
     21   USE par_ice          ! LIM parameters 
     22   USE dom_ice          ! LIM domain 
     23   USE thd_ice          ! LIM thermodynamical variables 
     24   USE limitd_me        ! LIM ice thickness distribution 
     25   USE limrhg           ! LIM dynamics 
     26   USE limmsh           ! LIM mesh 
     27   USE limistate        ! LIM initial state 
     28   USE limrst           ! LIM restart 
     29   USE limthd           ! LIM ice thermodynamics 
     30   USE limthd_sal       ! LIM ice thermodynamics: salinity 
     31   USE limvar           ! LIM variables 
     32   USE limsbc           ! LIM surface boundary condition 
     33   USE in_out_manager   ! I/O manager 
     34   USE lib_mpp          ! MPP library 
    2935 
    3036   IMPLICIT NONE 
    … …  
    3440 
    3541   !!---------------------------------------------------------------------- 
    36    !! NEMO/LIM3 4/0 , UCL - NEMO Consortium (2010) 
     42   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3743   !! $Id$ 
    3844   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4450      !!                  ***  ROUTINE ice_init  *** 
    4551      !! 
    46       !! ** purpose :    
     52      !! ** purpose :   Allocate all the dynamic arrays of the LIM-3 modules 
    4753      !!---------------------------------------------------------------------- 
    4854      INTEGER :: ierr 
    … …  
    5056 
    5157      !                                ! Allocate the ice arrays 
    52       ierr = ice_alloc()                     ! NB: Calls to the _alloc() routines should be in  
    53       !                                      !     the same order as the ice modules are USE'd above 
    54        
    55 !     ierr = ierr + ice_alloc_2() 
    56 !     ierr = ierr + lim_dia_alloc_2() 
    57 !     ierr = ierr + lim_hdf_alloc_2() 
    58 !     ierr = ierr + lim_sbc_alloc_2() 
    59 !     ierr = ierr + lim_wri_alloc_2() 
    60 !     ierr = ierr + thd_ice_alloc_2() 
    61  
    62 !     ierr = ierr + lim_rhg_alloc() 
    63 !     ierr = ierr + dom_ice_alloc() 
    64 !     ierr = ierr + lim_idt_me_alloc() 
    65 !     ierr = ierr + thd_ice_alloc() 
    66  
    67       IF( lk_mpp )   CALL mpp_sum( ierr ) 
     58      ierr =        ice_alloc       ()       ! ice variables 
     59      ierr = ierr + dom_ice_alloc   ()       ! domain 
     60      ierr = ierr + sbc_ice_alloc   ()       ! surface forcing 
     61      ierr = ierr + thd_ice_alloc   ()       ! thermodynamics 
     62      ierr = ierr + lim_itd_me_alloc()       ! ice thickness distribution - mechanics 
     63      ierr = ierr + lim_rhg_alloc   ()       ! dynamics 
     64      ! 
     65      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     66      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'ice_init : unable to allocate ice arrays' ) 
    6867 
    6968      IF( ierr > 0 ) THEN 
    7069         WRITE(numout,*)  
    7170         WRITE(numout,*) 'ERROR: Allocation of memory failed in nemo_alloc' 
    72          IF( lk_mpp ) CALL mppstop() 
     71         IF( lk_mpp )   CALL mppstop() 
    7372         STOP 
    7473      END IF 
    … …  
    7776      CALL ctl_opn( numnam_ice, 'namelist_ice', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp ) 
    7877      ! 
    79       CALL ice_run                     ! namelist read some ice run parameters 
    80       ! 
    81       CALL lim_thd_init                ! namelist read ice thermodynics parameters 
    82       ! 
    83       CALL lim_thd_sal_init            ! namelist read ice salinity parameters 
     78      CALL ice_run                     ! set some ice run parameters 
     79      ! 
     80      CALL lim_thd_init                ! set ice thermodynics parameters 
     81      ! 
     82      CALL lim_thd_sal_init            ! set ice salinity parameters 
    8483      ! 
    8584      rdt_ice = nn_fsbc * rdttra(1)    ! sea-ice timestep 
    … …  
    8786      CALL lim_msh                     ! ice mesh initialization 
    8887      ! 
    89       CALL lim_itd_ini                 ! initialize the ice thickness distribution 
     88      CALL lim_itd_ini                 ! ice thickness distribution initialization 
     89      ! 
     90      CALL lim_sbc_init                ! ice surface boundary condition    
     91 
    9092 
    9193      !                                ! Initial sea-ice state 
    … …  
    121123      !! 
    122124      !! ** Method  :   Read the namicerun namelist and check the parameter  
    123       !!       values called at the first timestep (nit000) 
     125      !!              values called at the first timestep (nit000) 
    124126      !! 
    125127      !! ** input   :   Namelist namicerun 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limadv.F90

    r2528 r2612  
    66   !! History :  LIM  ! 2008-03 (M. Vancoppenolle)  LIM-3 from LIM-2 code 
    77   !!            3.2  ! 2009-06 (F. Dupont)  correct a error in the North fold b. c. 
     8   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    89   !!-------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    1415   !!   lim_adv_y  : advection of sea ice on y axis 
    1516   !!---------------------------------------------------------------------- 
    16    USE dom_oce 
    17    USE dom_ice 
    18    USE ice 
    19    USE lbclnk 
    20    USE in_out_manager  ! I/O manager 
    21    USE prtctl          ! Print control 
     17   USE dom_oce          ! ocean domain 
     18   USE dom_ice          ! LIM-3 domain 
     19   USE ice              ! LIM-3 variables 
     20   USE lbclnk           ! lateral boundary condition - MPP exchanges 
     21   USE in_out_manager   ! I/O manager 
     22   USE prtctl           ! Print control 
    2223 
    2324   IMPLICIT NONE 
    … …  
    2728   PUBLIC   lim_adv_y   ! called by lim_trp 
    2829 
    29    REAL(wp)  ::   epsi20 = 1.e-20   ! constant values 
    30    REAL(wp)  ::   rzero  = 0.e0     !    -       - 
    31    REAL(wp)  ::   rone   = 1.e0     !    -       - 
     30   REAL(wp)  ::   epsi20 = 1.e-20_wp   ! constant values 
     31   REAL(wp)  ::   rzero  = 0._wp       !    -       - 
     32   REAL(wp)  ::   rone   = 1._wp       !    -       - 
    3233 
    3334   !! * Substitutions 
    3435#  include "vectopt_loop_substitute.h90" 
    3536   !!---------------------------------------------------------------------- 
    36    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     37   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3738   !! $Id$ 
    38    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    39    !!---------------------------------------------------------------------- 
    40  
     39   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     40   !!---------------------------------------------------------------------- 
    4141CONTAINS 
    4242 
    … …  
    5555      !! Reference:  Prather, 1986, JGR, 91, D6. 6671-6681. 
    5656      !!-------------------------------------------------------------------- 
     57      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     58      USE wrk_nemo, ONLY:   zf0  => wrk_2d_11 , zfx   => wrk_2d_12 , zfy    => wrk_2d_13 , zbet => wrk_2d_14   ! 2D workspace 
     59      USE wrk_nemo, ONLY:   zfm  => wrk_2d_15 , zfxx  => wrk_2d_16 , zfyy   => wrk_2d_17 , zfxy => wrk_2d_18   !  -      - 
     60      USE wrk_nemo, ONLY:   zalg => wrk_2d_19 , zalg1 => wrk_2d_20 , zalg1q => wrk_2d_21                       !  -      - 
     61      ! 
    5762      REAL(wp)                    , INTENT(in   ) ::   pdf                ! reduction factor for the time step 
    5863      REAL(wp)                    , INTENT(in   ) ::   pcrh               ! call lim_adv_x then lim_adv_y (=1) or the opposite (=0) 
    … …  
    6469      !!  
    6570      INTEGER  ::   ji, jj                               ! dummy loop indices 
    66       REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp, zin0   ! temporary scalars 
    67       REAL(wp) ::   zs1new, zalf , zalfq , zbt           !    -         - 
    68       REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !    -         - 
    69       REAL(wp), DIMENSION(jpi,jpj) ::   zf0, zfx , zfy , zbet   ! 2D workspace 
    70       REAL(wp), DIMENSION(jpi,jpj) ::   zfm, zfxx, zfyy, zfxy   !  -      - 
    71       REAL(wp), DIMENSION(jpi,jpj) ::   zalg, zalg1, zalg1q     !  -      - 
     71      REAL(wp) ::   zs1max, zrdt, zslpmax, ztemp, zin0   ! local scalars 
     72      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !   -      - 
     73      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !   -      - 
    7274      !--------------------------------------------------------------------- 
     75 
     76      IF( .NOT. wrk_use(2, 11,12,13,14,15,16,17,18,19,20,21) ) THEN 
     77         CALL ctl_stop( 'lim_adv_x : requested workspace arrays unavailable.' )   ;   RETURN 
     78      END IF 
    7379 
    7480      ! Limitation of moments.                                            
    … …  
    216222         CALL prt_ctl(tab2d_1=psxy , clinfo1=' lim_adv_x: psxy :') 
    217223      ENDIF 
     224      ! 
     225      IF( .NOT. wrk_release(2, 11,12,13,14,15,16,17,18,19,20,21) ) THEN 
     226         CALL ctl_stop( 'lim_adv_x : failed to release workspace arrays.' ) 
     227      END IF 
    218228      ! 
    219229   END SUBROUTINE lim_adv_x 
    … …  
    234244      !! Reference:  Prather, 1986, JGR, 91, D6. 6671-6681. 
    235245      !!--------------------------------------------------------------------- 
     246      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     247      USE wrk_nemo, ONLY:   zf0  => wrk_2d_11 , zfx   => wrk_2d_12 , zfy    => wrk_2d_13 , zbet => wrk_2d_14   ! 2D workspace 
     248      USE wrk_nemo, ONLY:   zfm  => wrk_2d_15 , zfxx  => wrk_2d_16 , zfyy   => wrk_2d_17 , zfxy => wrk_2d_18   !  -      - 
     249      USE wrk_nemo, ONLY:   zalg => wrk_2d_19 , zalg1 => wrk_2d_20 , zalg1q => wrk_2d_21                       !  -      - 
     250      ! 
    236251      REAL(wp)                    , INTENT(in   ) ::   pdf                ! reduction factor for the time step 
    237252      REAL(wp)                    , INTENT(in   ) ::   pcrh               ! call lim_adv_x then lim_adv_y (=1) or the opposite (=0) 
    … …  
    246261      REAL(wp) ::   zs1new, zalf , zalfq , zbt           !    -         - 
    247262      REAL(wp) ::   zs2new, zalf1, zalf1q, zbt1          !    -         - 
    248       REAL(wp), DIMENSION(jpi,jpj) ::   zf0, zfx , zfy , zbet   ! 2D workspace 
    249       REAL(wp), DIMENSION(jpi,jpj) ::   zfm, zfxx, zfyy, zfxy   !  -      - 
    250       REAL(wp), DIMENSION(jpi,jpj) ::   zalg, zalg1, zalg1q     !  -      - 
    251263      !--------------------------------------------------------------------- 
     264 
     265      IF(.NOT. wrk_use(2, 11,12,13,14,15,16,17,18,19,20,21) ) THEN 
     266         CALL ctl_stop( 'lim_adv_y : requested workspace arrays unavailable.' )   ;   RETURN 
     267      END IF 
    252268 
    253269      ! Limitation of moments. 
    … …  
    397413      ENDIF 
    398414      ! 
     415      IF( .NOT. wrk_release(2, 11,12,13,14,15,16,17,18,19,20,21) ) THEN 
     416         CALL ctl_stop( 'lim_adv_y : failed to release workspace arrays.' ) 
     417      END IF 
     418      ! 
    399419   END SUBROUTINE lim_adv_y 
    400  
    401420 
    402421#else 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limcons.F90

    r2528 r2612  
    11MODULE limcons 
     2   !!====================================================================== 
     3   !!                   ***  MODULE  limcons  *** 
     4   !! LIM-3 Sea Ice :   conservation check 
     5   !!====================================================================== 
     6   !! History :   -   ! Original code from William H. Lipscomb, LANL 
     7   !!            3.0  ! 2004-06  (M. Vancoppenolle)   Energy Conservation  
     8   !!            4.0  ! 2011-02  (G. Madec)  add mpp considerations 
     9   !!---------------------------------------------------------------------- 
    210#if defined key_lim3 
    311   !!---------------------------------------------------------------------- 
    412   !!   'key_lim3' :                                   LIM3 sea-ice model 
    513   !!---------------------------------------------------------------------- 
    6    !! 
    7    !!====================================================================== 
    8    !!                     ***  MODULE  limcons  *** 
    9    !! 
    10    !! This module checks whether 
    11    !!   Ice Total Energy 
    12    !!   Ice Total Mass 
    13    !!   Salt Mass 
    14    !! Are conserved ! 
    15    !!  
    16    !!====================================================================== 
    17    !!    lim_cons   :   checks whether energy/mass are conserved  
     14   !!    lim_cons   :   checks whether energy, mass and salt are conserved  
    1815   !!---------------------------------------------------------------------- 
    19    !! 
    20    !! * Modules used 
    21  
    22    USE par_ice 
    23    USE dom_oce 
    24    USE dom_ice 
    25    USE ice 
    26    USE in_out_manager  ! I/O manager 
     16   USE par_ice          ! LIM-3 parameter 
     17   USE ice              ! LIM-3 variables 
     18   USE dom_ice          ! LIM-3 domain 
     19   USE dom_oce          ! ocean domain 
     20   USE in_out_manager   ! I/O manager 
     21   USE lib_mpp          ! MPP library 
    2722 
    2823   IMPLICIT NONE 
    2924   PRIVATE 
    3025 
    31    !! * Accessibility 
    32    PUBLIC lim_column_sum 
    33    PUBLIC lim_column_sum_energy 
    34    PUBLIC lim_cons_check 
    35  
    36    !! * Module variables 
    37    !!---------------------------------------------------------------------- 
    38    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
    39    !! $Id$ 
    40    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    41    !!---------------------------------------------------------------------- 
     26   PUBLIC   lim_column_sum 
     27   PUBLIC   lim_column_sum_energy 
     28   PUBLIC   lim_cons_check 
    4229 
    4330   !!---------------------------------------------------------------------- 
    44  
     31   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
     32   !! $Id$ 
     33   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     34   !!---------------------------------------------------------------------- 
    4535CONTAINS 
    4636 
    47    !=============================================================================== 
    48  
    49    SUBROUTINE lim_column_sum(nsum,xin,xout) 
    50       !     !!------------------------------------------------------------------- 
    51       !     !!               ***  ROUTINE lim_column_sum *** 
    52       !     !! 
    53       !     !! ** Purpose : Compute the sum of xin over nsum categories 
    54       !     !! 
    55       !     !! ** Method  : Arithmetics 
    56       !     !! 
    57       !     !! ** Action  : Gets xin(ji,jj,jl) and computes xout(ji,jj) 
    58       !     !! 
    59       !     !! History : 
    60       !     !!   author: William H. Lipscomb, LANL 
    61       !     !!   2.1  !  04-06  (M. Vancoppenolle)   Energy Conservation  
    62       !     !!--------------------------------------------------------------------- 
    63       !     !! * Local variables 
    64       INTEGER, INTENT(in) ::     & 
    65          nsum                  ! number of categories/layers 
    66  
    67       REAL (wp), DIMENSION(jpi, jpj, jpl), INTENT(IN) ::   & 
    68          xin                   ! input field 
    69  
    70       REAL (wp), DIMENSION(jpi, jpj), INTENT(OUT) ::  & 
    71          xout                  ! output field 
    72       INTEGER ::                 & 
    73          ji, jj, jl         ! horizontal indices 
    74  
    75       !     !!--------------------------------------------------------------------- 
    76       !     WRITE(numout,*) ' lim_column_sum ' 
    77       !     WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    78  
    79       xout(:,:) = 0.00 
    80  
    81       DO jl = 1, nsum 
    82          DO jj = 1, jpj 
    83             DO ji = 1, jpi 
    84                xout(ji,jj) = xout(ji,jj) + xin(ji,jj,jl) 
    85             END DO ! ji  
    86          END DO  ! jj  
    87       END DO  ! jl  
    88  
     37   SUBROUTINE lim_column_sum( ksum, pin, pout ) 
     38      !!------------------------------------------------------------------- 
     39      !!               ***  ROUTINE lim_column_sum *** 
     40      !! 
     41      !! ** Purpose : Compute the sum of xin over nsum categories 
     42      !! 
     43      !! ** Method  : Arithmetics 
     44      !! 
     45      !! ** Action  : Gets xin(ji,jj,jl) and computes xout(ji,jj) 
     46      !!--------------------------------------------------------------------- 
     47      INTEGER                   , INTENT(in   ) ::   ksum   ! number of categories/layers 
     48      REAL(wp), DIMENSION(:,:,:), INTENT(in   ) ::   pin    ! input field 
     49      REAL(wp), DIMENSION(:,:)  , INTENT(  out) ::   pout   ! output field 
     50      ! 
     51      INTEGER ::   jl   ! dummy loop indices 
     52      !!--------------------------------------------------------------------- 
     53      ! 
     54      pout(:,:) = pin(:,:,1) 
     55      DO jl = 2, ksum 
     56         pout(:,:) = pout(:,:) + pin(:,:,jl) 
     57      END DO 
     58      ! 
    8959   END SUBROUTINE lim_column_sum 
    9060 
    91    !=============================================================================== 
    9261 
    93    SUBROUTINE lim_column_sum_energy(nsum,nlay,xin,xout) 
    94  
     62   SUBROUTINE lim_column_sum_energy( ksum, klay, pin, pout) 
    9563      !!------------------------------------------------------------------- 
    9664      !!               ***  ROUTINE lim_column_sum_energy *** 
    … …  
    10068      !! 
    10169      !! ** Method  : Arithmetics 
    102       !! 
    103       !! ** Action  : Gets xin(ji,jj,jl) and computes xout(ji,jj) 
    104       !! 
    105       !! History : 
    106       !!   author: William H. Lipscomb, LANL 
    107       !!   2.1  !  04-06  (M. Vancoppenolle)   Energy Conservation  
    10870      !!--------------------------------------------------------------------- 
    109       !! * Local variables 
    110       INTEGER, INTENT(in) ::  & 
    111          nsum,              &  !: number of categories 
    112          nlay                  !: number of vertical layers 
    113  
    114       REAL (wp), DIMENSION(jpi, jpj, jkmax, jpl), INTENT(IN) :: & 
    115          xin                   !: input field 
    116  
    117       REAL (wp), DIMENSION(jpi, jpj), INTENT(OUT) ::  & 
    118          xout                  !: output field 
    119  
    120       INTEGER ::              & 
    121          ji, jj,            &  !: horizontal indices 
    122          jk, jl                !: layer and category  indices 
     71      INTEGER                               , INTENT(in   ) ::   ksum   !: number of categories 
     72      INTEGER                               , INTENT(in   ) ::   klay   !: number of vertical layers 
     73      REAL(wp), DIMENSION(jpi,jpj,jkmax,jpl), INTENT(in   ) ::   pin   !: input field 
     74      REAL(wp), DIMENSION(jpi,jpj)          , INTENT(  out) ::   pout   !: output field 
     75      ! 
     76      INTEGER ::   jk, jl   ! dummy loop indices 
    12377      !!--------------------------------------------------------------------- 
    124  
    125       !     WRITE(numout,*) ' lim_column_sum_energy ' 
    126       !     WRITE(numout,*) ' ~~~~~~~~~~~~~~~~~~~~~ ' 
    127  
    128       xout(:,:) = 0.00 
    129  
    130       DO jl = 1, nsum 
    131          DO jk = 1, nlay  
    132             DO jj = 1, jpj 
    133                DO ji = 1, jpi 
    134                   xout(ji,jj) = xout(ji,jj) + xin(ji,jj,jk,jl) 
    135                END DO ! ji  
    136             END DO  ! jj  
    137          END DO  ! jk 
    138       END DO ! jl 
    139  
     78      ! 
     79      DO jl = 1, ksum 
     80         pout(:,:) = pin(:,:,1,jl) 
     81         DO jk = 2, klay  
     82            pout(:,:) = pout(:,:) + pin(:,:,jk,jl) 
     83         END DO 
     84      END DO 
     85      ! 
    14086   END SUBROUTINE lim_column_sum_energy 
    14187 
    142    !=============================================================================== 
    14388 
    144    SUBROUTINE lim_cons_check(x1, x2, max_err, fieldid) 
     89   SUBROUTINE lim_cons_check( px1, px2, pmax_err, cd_fieldid ) 
    14590      !!------------------------------------------------------------------- 
    14691      !!               ***  ROUTINE lim_cons_check *** 
    … …  
    15297      !! 
    15398      !! ** Method  : 
    154       !! 
    155       !! ** Action  : - 
    156       !! History : 
    157       !!   author: William H. Lipscomb, LANL 
    158       !!   2.1  !  04-06  (M. Vancoppenolle)   Energy Conservation  
    15999      !!--------------------------------------------------------------------- 
    160       !! * Local variables 
     100      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   px1          !: initial field 
     101      REAL(wp), DIMENSION(:,:), INTENT(in   ) ::   px2          !: final field 
     102      REAL(wp)                , INTENT(in   ) ::   pmax_err     !: max allowed error 
     103      CHARACTER(len=15)       , INTENT(in   ) ::   cd_fieldid   !: field identifyer 
     104      ! 
     105      INTEGER  ::   ji, jj          ! dummy loop indices 
     106      INTEGER  ::   inb_error       ! number of g.c where there is a cons. error 
     107      LOGICAL  ::   llconserv_err   ! = .true. if conservation check failed 
     108      REAL(wp) ::   zmean_error     ! mean error on error points 
     109      !!--------------------------------------------------------------------- 
     110      ! 
     111      IF(lwp) WRITE(numout,*) ' lim_cons_check ' 
     112      IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    161113 
    162       REAL (wp), DIMENSION(jpi, jpj), INTENT(IN) ::   & 
    163          x1 (jpi,jpj) , & !: initial field 
    164          x2 (jpi,jpj)     !: final field 
     114      llconserv_err = .FALSE. 
     115      inb_error     = 0 
     116      zmean_error   = 0._wp 
     117      IF( MAXVAL( px2(:,:) - px1(:,:) ) > pmax_err )   llconserv_err = .TRUE. 
    165118 
    166       REAL (wp) , INTENT ( IN )                  ::   & 
    167          max_err          !: max allowed error 
    168  
    169       REAL (wp)                                  ::   & 
    170          mean_error       !: mean error on error points 
    171  
    172       INTEGER                                    ::   & 
    173          num_error        !: number of g.c where there is a cons. error 
    174  
    175       CHARACTER(len=15) , INTENT(IN)             ::   & 
    176          fieldid          !: field identifyer 
    177  
    178       INTEGER ::              & 
    179          ji, jj           !: horizontal indices       
    180  
    181       LOGICAL ::              & 
    182          conserv_err      !: = .true. if conservation check failed 
    183  
    184       !!--------------------------------------------------------------------- 
    185       WRITE(numout,*) ' lim_cons_check ' 
    186       WRITE(numout,*) ' ~~~~~~~~~~~~~~ ' 
    187  
    188       conserv_err = .FALSE. 
    189       DO jj = 1, jpj 
    190          DO ji = 1, jpi 
    191             IF (ABS(x2(ji,jj) - x1(ji,jj)) .GT. max_err) THEN 
    192                conserv_err = .TRUE. 
    193             ENDIF 
    194          END DO 
    195       END DO 
    196  
    197       IF ( conserv_err ) THEN 
    198  
    199          num_error  = 0 
    200          mean_error = 0.0 
     119      IF( llconserv_err ) THEN 
    201120         DO jj = 1, jpj  
    202121            DO ji = 1, jpi 
    203                IF (ABS(x2(ji,jj) - x1(ji,jj)) .GT. max_err ) THEN 
    204                   num_error  = num_error + 1 
    205                   mean_error = mean_error + ABS(x2(ji,jj) - x1(ji,jj)) 
    206  
    207                   WRITE (numout,*) ' ALERTE 99 ' 
    208                   WRITE (numout,*) ' Conservation error: ', fieldid 
    209                   WRITE (numout,*) ' Point         : ', ji, jj  
    210                   WRITE (numout,*) ' lat, lon      : ', gphit(ji,jj), &  
    211                      glamt(ji,jj) 
    212                   WRITE (numout,*) ' Initial value : ', x1(ji,jj) 
    213                   WRITE (numout,*) ' Final value   : ', x2(ji,jj) 
    214                   WRITE (numout,*) ' Difference    : ', x2(ji,jj) - x1(ji,jj) 
    215  
     122               IF( ABS( px2(ji,jj) - px1(ji,jj) ) > pmax_err ) THEN 
     123                  inb_error   = inb_error + 1 
     124                  zmean_error = zmean_error + ABS( px2(ji,jj) - px1(ji,jj) ) 
     125                  ! 
     126                  IF(lwp) THEN 
     127                     WRITE (numout,*) ' ALERTE 99 ' 
     128                     WRITE (numout,*) ' Conservation error: ', cd_fieldid 
     129                     WRITE (numout,*) ' Point             : ', ji, jj  
     130                     WRITE (numout,*) ' lat, lon          : ', gphit(ji,jj), glamt(ji,jj) 
     131                     WRITE (numout,*) ' Initial value     : ', px1(ji,jj) 
     132                     WRITE (numout,*) ' Final value       : ', px2(ji,jj) 
     133                     WRITE (numout,*) ' Difference        : ', px2(ji,jj) - px1(ji,jj) 
     134                  ENDIF 
    216135               ENDIF 
    217136            END DO 
    218137         END DO 
    219  
    220          IF ( num_error .GT. 0 ) mean_error = mean_error / num_error 
    221          WRITE(numout,*) ' Conservation check for : ', fieldid 
    222          WRITE(numout,*) ' Number of error points : ', num_error 
    223          WRITE(numout,*) ' Mean error on these pts: ', mean_error 
    224  
    225       ENDIF ! conserv_err 
    226  
     138         ! 
     139      ENDIF 
     140      IF(lk_mpp)   CALL mpp_sum( inb_error   ) 
     141      IF(lk_mpp)   CALL mpp_sum( zmean_error ) 
     142      ! 
     143      IF( inb_error > 0 .AND. lwp ) THEN 
     144         zmean_error = zmean_error / REAL( inb_error, wp ) 
     145         WRITE(numout,*) ' Conservation check for : ', cd_fieldid 
     146         WRITE(numout,*) ' Number of error points : ', inb_error 
     147         WRITE(numout,*) ' Mean error on these pts: ', zmean_error 
     148      ENDIF 
     149      ! 
    227150   END SUBROUTINE lim_cons_check 
    228151 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limdia.F90

    r2601 r2612  
    431431      ENDIF 
    432432 
    433       ALLOCATE( aire(jpi,jpj) , STAT=ierr ) 
    434       IF( ierr /= 0 ) THEN 
    435          CALL ctl_stop( 'lim_dia_init : unable to allocate standard arrays' )   ;   RETURN 
    436       ENDIF 
    437        
    438       aire(:,:) = area(:,:) * tms(:,:) * tmask_i(:,:)      ! masked grid cell area (interior domain only) 
     433      ALLOCATE( aire(jpi,jpj) , STAT=ierr )      ! masked grid cell area (interior domain only) 
     434      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     435      IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_dia_init_2 : unable to allocate arrays' ) 
     436      aire(:,:) = area(:,:) * tms(:,:) * tmask_i(:,:) 
    439437 
    440438      ! Titles of ice key variables : 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limdyn.F90

    r2528 r2612  
    44   !!   Sea-Ice dynamics :   
    55   !!====================================================================== 
    6    !! history :  1.0  ! 2002-08 (C. Ethe, G. Madec)  original VP code  
    7    !!            3.0  ! 2007-03 (MA Morales Maqueda, S. Bouillon, M. Vancoppenolle)  LIM3: EVP-Cgrid 
     6   !! history :  1.0  ! 2002-08  (C. Ethe, G. Madec)  original VP code  
     7   !!            3.0  ! 2007-03  (MA Morales Maqueda, S. Bouillon, M. Vancoppenolle)  LIM3: EVP-Cgrid 
     8   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    1415   !!    lim_dyn_init : initialization and namelist read 
    1516   !!---------------------------------------------------------------------- 
    16    USE phycst 
    17    USE in_out_manager  ! I/O manager 
    18    USE dom_ice 
    19    USE dom_oce         ! ocean space and time domain 
    20    USE ice 
    21    USE par_ice 
    22    USE sbc_oce         ! Surface boundary condition: ocean fields 
    23    USE sbc_ice         ! Surface boundary condition: ice fields 
    24    USE limrhg          ! ice rheology 
    25    USE lbclnk 
    26    USE lib_mpp 
    27    USE prtctl          ! Print control 
     17   USE phycst           ! physical constants 
     18   USE dom_oce          ! ocean space and time domain 
     19   USE sbc_oce          ! Surface boundary condition: ocean fields 
     20   USE sbc_ice          ! Surface boundary condition: ice   fields 
     21   USE ice              ! LIM-3 variables 
     22   USE par_ice          ! LIM-3 parameters 
     23   USE dom_ice          ! LIM-3 domain 
     24   USE limrhg           ! LIM-3 rheology 
     25   USE lbclnk           ! lateral boundary conditions - MPP exchanges 
     26   USE lib_mpp          ! MPP library 
     27   USE in_out_manager   ! I/O manager 
     28   USE prtctl           ! Print control 
    2829 
    2930   IMPLICIT NONE 
    … …  
    3536#  include "vectopt_loop_substitute.h90" 
    3637   !!---------------------------------------------------------------------- 
    37    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     38   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3839   !! $Id$ 
    3940   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    5455      !!              - treatment of the case if no ice dynamic 
    5556      !!------------------------------------------------------------------------------------ 
     57      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     58      USE wrk_nemo, ONLY:   wrk_1d_1, wrk_1d_2 
     59      USE wrk_nemo, ONLY:   zu_io => wrk_2d_1, zv_io => wrk_2d_2  ! ice-ocean velocity 
     60      ! 
    5661      INTEGER, INTENT(in) ::   kt     ! number of iteration 
    5762      !! 
    … …  
    5964      INTEGER  ::   i_j1, i_jpj       ! Starting/ending j-indices for rheology 
    6065      REAL(wp) ::   zcoef             ! local scalar 
    61       REAL(wp), DIMENSION(jpj)     ::   zind           ! i-averaged indicator of sea-ice 
    62       REAL(wp), DIMENSION(jpj)     ::   zmsk           ! i-averaged of tmask 
    63       REAL(wp), DIMENSION(jpi,jpj) ::   zu_io, zv_io   ! ice-ocean velocity 
     66      REAL(wp), POINTER, DIMENSION(:) ::   zind     ! i-averaged indicator of sea-ice 
     67      REAL(wp), POINTER, DIMENSION(:) ::   zmsk     ! i-averaged of tmask 
    6468      !!--------------------------------------------------------------------- 
    6569 
    66       IF( kt == nit000 .AND. lwp ) THEN 
    67          WRITE(numout,*) ' lim_dyn : Ice dynamics ' 
    68          WRITE(numout,*) ' ~~~~~~~ ' 
    69       ENDIF 
    70  
    71       IF( numit == nstart  )   CALL lim_dyn_init   ! Initialization (first time-step only) 
    72  
    73       IF ( ln_limdyn ) THEN 
    74  
     70      IF(  .NOT. wrk_use(1, 1,2)  .OR.  .NOT. wrk_use(2, 1,2)  ) THEN 
     71         CALL ctl_stop( 'lim_dyn : requested workspace arrays unavailable.' )   ;   RETURN 
     72      END IF 
     73      zind => wrk_1d_1(1:jpj)      ! Set-up pointers to sub-arrays of workspaces 
     74      zmsk => wrk_1d_2(1:jpj) 
     75 
     76      IF( kt == nit000 )   CALL lim_dyn_init   ! Initialization (first time-step only) 
     77 
     78      IF( ln_limdyn ) THEN 
     79         ! 
    7580         old_u_ice(:,:) = u_ice(:,:) * tmu(:,:) 
    7681         old_v_ice(:,:) = v_ice(:,:) * tmv(:,:) 
    … …  
    8893            CALL lim_rhg( i_j1, i_jpj ) 
    8994         ELSE                                 ! optimization of the computational area 
    90  
     95            ! 
    9196            DO jj = 1, jpj 
    92                zind(jj) = SUM( 1.0 - at_i (:,jj  ) )   ! = FLOAT(jpj) if ocean everywhere on a j-line 
    93                zmsk(jj) = SUM( tmask(:,jj,1) )   ! = 0          if land  everywhere on a j-line 
     97               zind(jj) = SUM( 1.0 - at_i(:,jj) )   ! = REAL(jpj) if ocean everywhere on a j-line 
     98               zmsk(jj) = SUM( tmask(:,jj,1)    )   ! = 0         if land  everywhere on a j-line 
    9499            END DO 
    95100 
    … …  
    106111               IF(ln_ctl) CALL prt_ctl_info( 'lim_dyn  : NH  i_j1 = ', ivar1=i_j1, clinfo2=' ij_jpj = ', ivar2=i_jpj ) 
    107112               CALL lim_rhg( i_j1, i_jpj ) 
    108  
     113               ! 
    109114               ! Southern hemisphere 
    110115               i_j1  =  1 
    … …  
    115120               i_jpj = MIN( jpj, i_jpj+1 ) 
    116121               IF(ln_ctl) CALL prt_ctl_info( 'lim_dyn  : SH  i_j1 = ', ivar1=i_j1, clinfo2=' ij_jpj = ', ivar2=i_jpj ) 
    117  
    118        CALL lim_rhg( i_j1, i_jpj ) 
    119  
    120     ELSE                                 ! local domain extends over one hemisphere only 
    121        !                                 ! Rheology is computed only over the ice cover 
    122        !                                 ! latitude strip 
    123        i_j1  = 1 
     122               ! 
     123               CALL lim_rhg( i_j1, i_jpj ) 
     124               ! 
     125            ELSE                                 ! local domain extends over one hemisphere only 
     126               !                                 ! Rheology is computed only over the ice cover 
     127               !                                 ! latitude strip 
     128               i_j1  = 1 
    124129               DO WHILE ( i_j1 <= jpj .AND. zind(i_j1) == FLOAT(jpi) .AND. zmsk(i_j1) /=0 ) 
    125130                  i_j1 = i_j1 + 1 
    … …  
    132137               END DO 
    133138               i_jpj = MIN( jpj, i_jpj+1) 
    134  
     139               ! 
    135140               IF(ln_ctl) CALL prt_ctl_info( 'lim_dyn  : one hemisphere:  i_j1 = ', ivar1=i_j1, clinfo2=' ij_jpj = ', ivar2=i_jpj ) 
    136  
     141               ! 
    137142               CALL lim_rhg( i_j1, i_jpj ) 
    138  
     143               ! 
    139144            ENDIF 
    140  
     145            ! 
    141146         ENDIF 
    142147 
    … …  
    147152         zv_io(:,:) = v_ice(:,:) - ssv_m(:,:) 
    148153         ! frictional velocity at T-point 
    149          zcoef = 0.5 * cw 
     154         zcoef = 0.5_wp * cw 
    150155         DO jj = 2, jpjm1  
    151156            DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    157162      ELSE      ! no ice dynamics : transmit directly the atmospheric stress to the ocean 
    158163         ! 
    159          zcoef = SQRT( 0.5 ) / rau0 
     164         zcoef = SQRT( 0.5_wp ) / rau0 
    160165         DO jj = 2, jpjm1 
    161166            DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    207212      ENDIF 
    208213      ! 
     214      IF(  .NOT. wrk_release(1, 1,2)  .OR.  .NOT. wrk_release(2, 1,2)  ) THEN 
     215         CALL ctl_stop( 'lim_dyn : failed to release workspace arrays.' ) 
     216      END IF 
     217      ! 
    209218   END SUBROUTINE lim_dyn 
    210219 
    … …  
    271280      ahiu(:,:) = ahi0 * umask(:,:,1) 
    272281      ahiv(:,:) = ahi0 * vmask(:,:,1) 
    273  
     282      ! 
    274283   END SUBROUTINE lim_dyn_init 
    275284 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limhdf.F90

    r2601 r2612  
    7070      IF( linit ) THEN              ! Metric coefficient (compute at the first call and saved in efact) 
    7171         ALLOCATE( efact(jpi,jpj) , STAT=ierr ) 
    72          IF( ierr /= 0 ) THEN 
    73             CALL ctl_stop( 'lim_hdf : unable to allocate standard arrays' )   ;   RETURN 
    74          ENDIF 
     72         IF( lk_mpp    )   CALL mpp_sum( ierr ) 
     73         IF( ierr /= 0 )   CALL ctl_stop( 'STOP', 'lim_hdf : unable to allocate arrays' ) 
    7574         DO jj = 2, jpjm1   
    7675            DO ji = fs_2 , fs_jpim1   ! vector opt. 
    77                efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) & 
    78                   &          / ( e1t(ji,jj) * e2t(ji,jj) ) 
     76               efact(ji,jj) = ( e2u(ji,jj) + e2u(ji-1,jj) + e1v(ji,jj) + e1v(ji,jj-1) ) / ( e1t(ji,jj) * e2t(ji,jj) ) 
    7977            END DO 
    8078         END DO 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limistate.F90

    r2528 r2612  
    55   !!====================================================================== 
    66   !! History :  2.0  ! 2004-01 (C. Ethe, G. Madec)  Original code 
     7   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    78   !!---------------------------------------------------------------------- 
    89#if defined key_lim3 
    … …  
    4546 
    4647   !!---------------------------------------------------------------------- 
    47    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     48   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    4849   !! $Id$ 
    4950   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    6061      !!                or from arbitrary sea-ice conditions 
    6162      !!------------------------------------------------------------------- 
     63      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     64      USE wrk_nemo, ONLY:   wrk_1d_1, wrk_1d_2, wrk_1d_3, wrk_1d_4 
     65      USE wrk_nemo, ONLY:   zidto => wrk_2d_1   ! ice indicator 
     66      ! 
    6267      INTEGER  ::   ji, jj, jk, jl             ! dummy loop indices 
    6368      REAL(wp) ::   zeps6, zeps, ztmelts, epsi06   ! local scalars 
    64       REAL(wp) ::  zvol, zare, zh, zh1, zh2, zh3, zan, zbn, zas, zbs  
    65       REAL(wp), DIMENSION(jpm)     ::   zgfactorn, zhin  
    66       REAL(wp), DIMENSION(jpm)     ::   zgfactors, zhis 
    67       REAL(wp), DIMENSION(jpi,jpj) ::   zidto      ! ice indicator 
    68       !-------------------------------------------------------------------- 
     69      REAL(wp) ::   zvol, zare, zh, zh1, zh2, zh3, zan, zbn, zas, zbs  
     70      REAL(wp), POINTER, DIMENSION(:) ::   zgfactorn, zhin  
     71      REAL(wp), POINTER, DIMENSION(:) ::   zgfactors, zhis 
     72      !-------------------------------------------------------------------- 
     73 
     74      IF(  .NOT. wrk_use(1, 1,2)  ) THEN 
     75         CALL ctl_stop( 'lim_istate : requested workspace arrays unavailable.' )   ;   RETURN 
     76      END IF 
     77      zgfactorn => wrk_1d_1(1:jpm)   ;   zhin => wrk_1d_3(1:jpm)   ! Set-up pointers to sub-arrays of workspaces 
     78      zgfactors => wrk_1d_2(1:jpm)   ;   zhis => wrk_1d_4(1:jpm) 
    6979 
    7080      !-------------------------------------------------------------------- 
    … …  
    506516      CALL lbc_lnk( fsbbq  , 'T', 1. ) 
    507517      ! 
     518      IF(  .NOT. wrk_release(1, 1,2)  ) THEN 
     519         CALL ctl_stop( 'lim_istate : failed to release workspace arrays.' ) 
     520      END IF 
     521      ! 
    508522   END SUBROUTINE lim_istate 
    509523 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limitd_me.F90

    r2601 r2612  
    66   !! History :  LIM  ! 2006-02  (M. Vancoppenolle) Original code  
    77   !!            3.2  ! 2009-07  (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in smsw & fsalt_rpo 
     8   !!            4.0  ! 2011-02  (G. Madec) dynamical allocation 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    1516   USE phycst           ! physical constants (ocean directory)  
    1617   USE sbc_oce          ! surface boundary condition: ocean fields 
    17    USE thd_ice          ! LIM-3 thermodynamics 
    18    USE ice              ! LIM-3 variables 
    19    USE par_ice          ! LIM-3 parameters 
    20    USE dom_ice          ! LIM-3 domain 
    21    USE limthd_lac       ! LIM-3 
    22    USE limvar           ! LIM-3 
    23    USE limcons          ! LIM-3 
     18   USE thd_ice          ! LIM thermodynamics 
     19   USE ice              ! LIM variables 
     20   USE par_ice          ! LIM parameters 
     21   USE dom_ice          ! LIM domain 
     22   USE limthd_lac       ! LIM 
     23   USE limvar           ! LIM 
     24   USE limcons          ! LIM 
    2425   USE in_out_manager   ! I/O manager 
    2526   USE prtctl           ! Print control 
    2627   USE lbclnk           ! lateral boundary condition - MPP exchanges 
    2728   USE lib_mpp          ! MPP library 
    28    USE wrk_nemo, ONLY: wrk_use, wrk_release 
     29   USE wrk_nemo         ! workspace manager 
    2930 
    3031   IMPLICIT NONE 
    … …  
    3738   PUBLIC   lim_itd_me_alloc        ! called by nemogcm.F90 
    3839 
    39    REAL(wp)  ::   epsi06 = 1.e-06_wp   ! constant values 
    4040   REAL(wp)  ::   epsi11 = 1.e-11_wp   ! constant values 
    4141   REAL(wp)  ::   epsi10 = 1.e-10_wp   ! constant values 
     42   REAL(wp)  ::   epsi06 = 1.e-06_wp   ! constant values 
    4243 
    4344   !----------------------------------------------------------------------- 
    … …  
    6061   REAL(wp), PARAMETER ::   kraft   = 2.0_wp    ! rafting multipliyer 
    6162 
    62    REAL(wp) ::   Cp  
     63   REAL(wp) ::   Cp                             !  
    6364   ! 
    6465   !----------------------------------------------------------------------- 
    … …  
    141142      INTEGER ::   ji, jj, jk, jl   ! dummy loop index 
    142143      INTEGER ::   niter, nitermax = 20   ! local integer  
    143  
    144144      LOGICAL  ::   asum_error              ! flag for asum .ne. 1 
    145       INTEGER  ::   iterate_ridging ! if true, repeat the ridging 
    146       REAL(wp) ::   w1, tmpfac, dti   ! local scalar 
    147       REAL(wp) ::   big = 1.0e8 
     145      INTEGER  ::   iterate_ridging         ! if true, repeat the ridging 
     146      REAL(wp) ::   w1, tmpfac, dti         ! local scalar 
    148147      CHARACTER (len = 15) ::   fieldid 
    149148      !!----------------------------------------------------------------------------- 
    … …  
    168167      hi_max(jpl) = 999.99 
    169168 
    170       Cp = 0.5 * grav * (rau0-rhoic) * rhoic / rau0    ! proport const for PE 
     169      Cp = 0.5 * grav * (rau0-rhoic) * rhoic / rau0      ! proport const for PE 
    171170      CALL lim_itd_me_ridgeprep ! prepare ridging 
    172171 
    173       ! conservation check 
    174       IF ( con_i)   CALL lim_column_sum (jpl,   v_i, vt_i_init) 
    175  
    176       ! Initialize arrays. 
    177       DO jj = 1, jpj 
     172      IF( con_i)   CALL lim_column_sum( jpl, v_i, vt_i_init )      ! conservation check 
     173 
     174      DO jj = 1, jpj                                     ! Initialize arrays. 
    178175         DO ji = 1, jpi 
    179176            msnow_mlt(ji,jj) = 0._wp 
    180177            esnow_mlt(ji,jj) = 0._wp 
    181             dardg1dt(ji,jj)  = 0._wp 
    182             dardg2dt(ji,jj)  = 0._wp 
    183             dvirdgdt(ji,jj)  = 0._wp 
    184             opening (ji,jj)  = 0._wp 
     178            dardg1dt (ji,jj)  = 0._wp 
     179            dardg2dt (ji,jj)  = 0._wp 
     180            dvirdgdt (ji,jj)  = 0._wp 
     181            opening  (ji,jj)  = 0._wp 
    185182 
    186183            !-----------------------------------------------------------------------------! 
    … …  
    216213            divu_adv(ji,jj) = ( 1._wp - asum(ji,jj) ) / rdt_ice  ! asum found in ridgeprep 
    217214 
    218             IF(divu_adv(ji,jj) < 0._wp )   closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) 
     215            IF( divu_adv(ji,jj) < 0._wp )   closing_net(ji,jj) = MAX( closing_net(ji,jj), -divu_adv(ji,jj) ) 
    219216 
    220217            ! 2.3 opning 
    … …  
    223220            ! asum = 1.0 after ridging. 
    224221            opning(ji,jj) = closing_net(ji,jj) + divu_adv(ji,jj) 
    225  
    226222         END DO 
    227223      END DO 
    … …  
    269265            DO jj = 1, jpj 
    270266               DO ji = 1, jpi 
    271                   IF ( a_i(ji,jj,jl) .GT. epsi11 .AND. athorn(ji,jj,jl) .GT. 0.0 ) THEN 
     267                  IF ( a_i(ji,jj,jl) > epsi11 .AND. athorn(ji,jj,jl) > 0._wp )THEN 
    272268                     w1 = athorn(ji,jj,jl) * closing_gross(ji,jj) * rdt_ice 
    273                      IF ( w1 .GT. a_i(ji,jj,jl) ) THEN 
     269                     IF ( w1 > a_i(ji,jj,jl) ) THEN 
    274270                        tmpfac = a_i(ji,jj,jl) / w1 
    275271                        closing_gross(ji,jj) = closing_gross(ji,jj) * tmpfac 
    276                         opning(ji,jj) = opning(ji,jj) * tmpfac 
     272                        opning       (ji,jj) = opning       (ji,jj) * tmpfac 
    277273                     ENDIF 
    278274                  ENDIF 
    … …  
    301297            DO ji = 1, jpi 
    302298               IF (ABS(asum(ji,jj) - 1.0) .LT. epsi11) THEN 
    303                   closing_net(ji,jj) = 0.0  
    304                   opning(ji,jj)      = 0.0 
     299                  closing_net(ji,jj) = 0._wp 
     300                  opning     (ji,jj) = 0._wp 
    305301               ELSE 
    306302                  iterate_ridging    = 1 
    307                   divu_adv(ji,jj)    = (1.0 - asum(ji,jj)) / rdt_ice 
    308                   closing_net(ji,jj) = MAX(0.0, -divu_adv(ji,jj)) 
    309                   opning(ji,jj)      = MAX(0.0, divu_adv(ji,jj)) 
     303                  divu_adv   (ji,jj) = (1._wp - asum(ji,jj)) / rdt_ice 
     304                  closing_net(ji,jj) = MAX( 0._wp, -divu_adv(ji,jj) ) 
     305                  opning     (ji,jj) = MAX( 0._wp,  divu_adv(ji,jj) ) 
    310306               ENDIF 
    311307            END DO 
    312308         END DO 
    313309 
    314          IF( lk_mpp ) CALL mpp_max(iterate_ridging) 
     310         IF( lk_mpp )   CALL mpp_max( iterate_ridging ) 
    315311 
    316312         ! Repeat if necessary. 
    … …  
    321317         niter = niter + 1 
    322318 
    323          IF (iterate_ridging == 1) THEN 
    324             IF (niter .GT. nitermax) THEN 
     319         IF( iterate_ridging == 1 ) THEN 
     320            IF( niter .GT. nitermax ) THEN 
    325321               WRITE(numout,*) ' ALERTE : non-converging ridging scheme ' 
    326322               WRITE(numout,*) ' niter, iterate_ridging ', niter, iterate_ridging 
    … …  
    405401      d_oa_i_trp (:,:,:)   = oa_i (:,:,:)   - old_oa_i (:,:,:) 
    406402      d_smv_i_trp(:,:,:)   = 0._wp 
    407       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 
    408          d_smv_i_trp(:,:,:)  = smv_i(:,:,:) - old_smv_i(:,:,:) 
     403      IF(  num_sal == 2  .OR.  num_sal == 4  )   d_smv_i_trp(:,:,:)  = smv_i(:,:,:) - old_smv_i(:,:,:) 
    409404 
    410405      IF(ln_ctl) THEN     ! Control print 
    … …  
    453448      e_i(:,:,:,:)  = old_e_i(:,:,:,:) 
    454449      oa_i(:,:,:)   = old_oa_i(:,:,:) 
    455       IF ( ( num_sal == 2 ) .OR. ( num_sal == 4 ) )   smv_i(:,:,:)  = old_smv_i(:,:,:) 
     450      IF(  num_sal == 2  .OR.  num_sal == 4 )   smv_i(:,:,:)  = old_smv_i(:,:,:) 
    456451 
    457452      !----------------------------------------------------! 
    … …  
    467462            DO jj = 1, jpj 
    468463               DO ji = 1, jpi 
    469                   IF ( ( old_v_i(ji,jj,jl) .LT. epsi06 ) .AND. & 
    470                      ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 
     464                  IF ( ( old_v_i(ji,jj,jl) < epsi06 ) .AND. & 
     465                     ( d_v_i_trp(ji,jj,jl) > epsi06 ) ) THEN 
    471466                     old_e_i(ji,jj,jk,jl)   = d_e_i_trp(ji,jj,jk,jl) 
    472                      d_e_i_trp(ji,jj,jk,jl) = 0.0 
     467                     d_e_i_trp(ji,jj,jk,jl) = 0._wp 
    473468                  ENDIF 
    474469               END DO 
    … …  
    480475         DO jj = 1, jpj 
    481476            DO ji = 1, jpi 
    482                IF ( ( old_v_i(ji,jj,jl) .LT. epsi06 ) .AND. & 
    483                   ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 
     477               IF ( ( old_v_i(ji,jj,jl) < epsi06 ) .AND. & 
     478                  ( d_v_i_trp(ji,jj,jl) > epsi06 ) ) THEN 
    484479                  old_v_i(ji,jj,jl)     = d_v_i_trp(ji,jj,jl) 
    485                   d_v_i_trp(ji,jj,jl)   = 0.0 
     480                  d_v_i_trp(ji,jj,jl)   = 0._wp 
    486481                  old_a_i(ji,jj,jl)     = d_a_i_trp(ji,jj,jl) 
    487                   d_a_i_trp(ji,jj,jl)   = 0.0 
     482                  d_a_i_trp(ji,jj,jl)   = 0._wp 
    488483                  old_v_s(ji,jj,jl)     = d_v_s_trp(ji,jj,jl) 
    489                   d_v_s_trp(ji,jj,jl)   = 0.0 
     484                  d_v_s_trp(ji,jj,jl)   = 0._wp 
    490485                  old_e_s(ji,jj,1,jl)   = d_e_s_trp(ji,jj,1,jl) 
    491                   d_e_s_trp(ji,jj,1,jl) = 0.0 
     486                  d_e_s_trp(ji,jj,1,jl) = 0._wp 
    492487                  old_oa_i(ji,jj,jl)    = d_oa_i_trp(ji,jj,jl) 
    493                   d_oa_i_trp(ji,jj,jl)  = 0.0 
    494                   IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) &  
    495                      old_smv_i(ji,jj,jl)   = d_smv_i_trp(ji,jj,jl) 
    496                   d_smv_i_trp(ji,jj,jl) = 0.0 
     488                  d_oa_i_trp(ji,jj,jl)  = 0._wp 
     489                  IF(  num_sal == 2  .OR.  num_sal == 4  )   old_smv_i(ji,jj,jl)   = d_smv_i_trp(ji,jj,jl) 
     490                  d_smv_i_trp(ji,jj,jl) = 0._wp 
    497491               ENDIF 
    498492            END DO 
    … …  
    500494      END DO 
    501495 
    502       IF( .NOT. wrk_release(2, 1,2,3,4,5,6,7,8) ) THEN 
    503          CALL ctl_stop( 'lim_itd_me : failed to release workspace arrays.' ) 
    504       END IF 
     496      IF( .NOT. wrk_release(2, 1,2,3,4,5,6,7,8) )   CALL ctl_stop( 'lim_itd_me : failed to release workspace arrays.' ) 
    505497      ! 
    506498   END SUBROUTINE lim_itd_me 
    507499 
    508500 
    509    SUBROUTINE lim_itd_me_icestrength (kstrngth) 
     501   SUBROUTINE lim_itd_me_icestrength( kstrngth ) 
    510502      !!---------------------------------------------------------------------- 
    511503      !!                ***  ROUTINE lim_itd_me_icestrength *** 
    512       !! ** Purpose : 
    513       !!        This routine computes ice strength used in dynamics routines 
    514       !!                      of ice thickness 
    515       !! 
    516       !! ** Method  : 
    517       !!       Compute the strength of the ice pack, defined as the energy (J m-2)  
    518       !! dissipated per unit area removed from the ice pack under compression, 
    519       !! and assumed proportional to the change in potential energy caused 
    520       !! by ridging. Note that only Hibler's formulation is stable and that 
    521       !! ice strength has to be smoothed 
     504      !! 
     505      !! ** Purpose :   computes ice strength used in dynamics routines of ice thickness 
     506      !! 
     507      !! ** Method  :   Compute the strength of the ice pack, defined as the energy (J m-2)  
     508      !!              dissipated per unit area removed from the ice pack under compression, 
     509      !!              and assumed proportional to the change in potential energy caused 
     510      !!              by ridging. Note that only Hibler's formulation is stable and that 
     511      !!              ice strength has to be smoothed 
    522512      !! 
    523513      !! ** Inputs / Ouputs : kstrngth (what kind of ice strength we are using) 
    524       !! 
    525       !! ** External :  
    526       !! 
    527       !! ** References : 
    528       !!                 
    529514      !!---------------------------------------------------------------------- 
    530       USE wrk_nemo, ONLY: zworka => wrk_2d_1 !: temporary array used here 
    531       ! 
    532       INTEGER, INTENT(in) :: & 
    533          kstrngth    ! = 1 for Rothrock formulation, 0 for Hibler (1979) 
    534  
    535       INTEGER ::   & 
    536          ji,jj,    &         !: horizontal indices 
    537          jl,       &         !: thickness category index 
    538          ksmooth,  &         !: smoothing the resistance to deformation 
    539          numts_rm            !: number of time steps for the P smoothing 
    540  
    541       REAL(wp) ::  &   
    542          hi,       &         !: ice thickness (m) 
    543          zw1,      &         !: temporary variable 
    544          zp,       &         !: temporary ice strength  
    545          zdummy 
     515      USE wrk_nemo, ONLY: zworka => wrk_2d_1    ! 2D workspace 
     516      ! 
     517      INTEGER, INTENT(in) ::   kstrngth    ! = 1 for Rothrock formulation, 0 for Hibler (1979) 
     518 
     519      INTEGER ::   ji,jj, jl   ! dummy loop indices 
     520      INTEGER ::   ksmooth     ! smoothing the resistance to deformation 
     521      INTEGER ::   numts_rm    ! number of time steps for the P smoothing 
     522 
     523      REAL(wp) ::   hi, zw1, zp, zdummy, zzc, z1_3   ! local scalars 
    546524      !!---------------------------------------------------------------------- 
    547525 
    … …  
    563541      ! 3) Rothrock(1975)'s method 
    564542      !------------------------------------------------------------------------------! 
    565       IF (kstrngth == 1) then 
    566  
     543      IF( kstrngth == 1 ) THEN 
     544         z1_3 = 1._wp / 3._wp 
    567545         DO jl = 1, jpl 
    568546            DO jj= 1, jpj 
    569547               DO ji = 1, jpi 
    570  
    571                   IF(  a_i(ji,jj,jl)    .GT. epsi11  .AND.                    & 
    572                        athorn(ji,jj,jl) .GT. 0._wp   ) THEN 
     548                  ! 
     549                  IF(  a_i(ji,jj,jl)    > epsi11  .AND.     & 
     550                       athorn(ji,jj,jl) > 0._wp   ) THEN 
    573551                     hi = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    574552                     !---------------------------- 
    … …  
    580558                     ! PE gain from rafting ice 
    581559                     !-------------------------- 
    582                      strength(ji,jj) = strength(ji,jj) + 2.0 * araft(ji,jj,jl) * hi * hi 
     560                     strength(ji,jj) = strength(ji,jj) + 2._wp * araft(ji,jj,jl) * hi * hi 
    583561 
    584562                     !---------------------------- 
    585563                     ! PE gain from ridging ice 
    586564                     !---------------------------- 
    587                      strength(ji,jj) = strength(ji,jj)                         & 
    588                         + aridge(ji,jj,jl)/krdg(ji,jj,jl)                         & 
    589                         * 1.0/3.0 * (hrmax(ji,jj,jl)**3 - hrmin(ji,jj,jl)**3)     & 
    590                         / (hrmax(ji,jj,jl)-hrmin(ji,jj,jl))                       
     565                     strength(ji,jj) = strength(ji,jj) + aridge(ji,jj,jl)/krdg(ji,jj,jl)     & 
     566                        * z1_3 * (hrmax(ji,jj,jl)**3 - hrmin(ji,jj,jl)**3) / ( hrmax(ji,jj,jl)-hrmin(ji,jj,jl) )    
     567!!gm Optimization:  (a**3-b**3)/(a-b) = a*a+ab+b*b   ==> less costly operations even if a**3 is replaced by a*a*a...                     
    591568                  ENDIF            ! aicen > epsi11 
    592  
     569                  ! 
    593570               END DO ! ji 
    594571            END DO !jj 
    595572         END DO !jl 
    596573 
    597          DO jj = 1, jpj 
    598             DO ji = 1, jpi 
    599                strength(ji,jj) = Cf * Cp * strength(ji,jj) / aksum(ji,jj)  
    600                ! Cp = (g/2)*(rhow-rhoi)*(rhoi/rhow) 
    601                ! Cf accounts for frictional dissipation 
    602  
    603             END DO              ! j 
    604          END DO                 ! i 
     574         zzc = Cf * Cp     ! where Cp = (g/2)*(rhow-rhoi)*(rhoi/rhow) and Cf accounts for frictional dissipation 
     575         strength(:,:) = zzc * strength(:,:) / aksum(:,:) 
    605576 
    606577         ksmooth = 1 
    … …  
    610581         !------------------------------------------------------------------------------! 
    611582      ELSE                      ! kstrngth ne 1:  Hibler (1979) form 
    612  
    613          DO jj = 1, jpj 
    614             DO ji = 1, jpi 
    615                strength(ji,jj) = Pstar*vt_i(ji,jj)*exp(-C_rhg*(1.0-at_i(ji,jj))) 
    616             END DO              ! j 
    617          END DO                 ! i 
    618  
     583         ! 
     584         strength(:,:) = Pstar * vt_i(:,:) * EXP( - C_rhg * ( 1._wp - at_i(:,:) )  ) 
     585         ! 
    619586         ksmooth = 1 
    620  
     587         ! 
    621588      ENDIF                     ! kstrngth 
    622589 
    … …  
    627594      ! CAN BE REMOVED 
    628595      ! 
    629       IF ( brinstren_swi .EQ. 1 ) THEN 
     596      IF ( brinstren_swi == 1 ) THEN 
    630597 
    631598         DO jj = 1, jpj 
    … …  
    650617      ! Spatial smoothing 
    651618      !------------------- 
    652       IF ( ksmooth .EQ. 1 ) THEN 
     619      IF ( ksmooth == 1 ) THEN 
    653620 
    654621         CALL lbc_lnk( strength, 'T', 1. ) 
    … …  
    684651      ! Temporal smoothing 
    685652      !-------------------- 
    686       IF ( numit .EQ. nit000 + nn_fsbc - 1 ) THEN 
     653      IF ( numit == nit000 + nn_fsbc - 1 ) THEN 
    687654         strp1(:,:) = 0.0             
    688655         strp2(:,:) = 0.0             
    689656      ENDIF 
    690657 
    691       IF ( ksmooth .EQ. 2 ) THEN 
     658      IF ( ksmooth == 2 ) THEN 
    692659 
    693660 
    … …  
    696663         DO jj = 1, jpj - 1 
    697664            DO ji = 1, jpi - 1 
    698                IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi11) THEN ! ice is 
    699                   ! present 
     665               IF ( ( asum(ji,jj) - ato_i(ji,jj) ) .GT. epsi11) THEN       ! ice is present 
    700666                  numts_rm = 1 ! number of time steps for the running mean 
    701667                  IF ( strp1(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 
    702668                  IF ( strp2(ji,jj) .GT. 0.0 ) numts_rm = numts_rm + 1 
    703                   zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) /   & 
    704                      numts_rm 
     669                  zp = ( strength(ji,jj) + strp1(ji,jj) + strp2(ji,jj) ) / numts_rm 
    705670                  strp2(ji,jj) = strp1(ji,jj) 
    706671                  strp1(ji,jj) = strength(ji,jj) 
    … …  
    726691      !!---------------------------------------------------------------------! 
    727692      !!                ***  ROUTINE lim_itd_me_ridgeprep *** 
    728       !! ** Purpose : 
    729       !!         preparation for ridging and strength calculations 
    730       !! 
    731       !! ** Method  : 
    732       !! Compute the thickness distribution of the ice and open water  
    733       !! participating in ridging and of the resulting ridges. 
    734       !! 
     693      !! 
     694      !! ** Purpose :   preparation for ridging and strength calculations 
     695      !! 
     696      !! ** Method  :   Compute the thickness distribution of the ice and open water  
     697      !!              participating in ridging and of the resulting ridges. 
    735698      !!---------------------------------------------------------------------! 
    736       INTEGER :: & 
    737          ji,jj,  &          ! horizontal indices 
    738          jl,     &          ! thickness category index 
    739          krdg_index         ! which participation function using 
    740  
    741       REAL(wp)            ::     & 
    742          Gstari, &          !  = 1.0/Gstar     
    743          astari             !  = 1.0/astar 
    744  
    745       REAL(wp), DIMENSION(jpi,jpj,-1:jpl) ::    & 
    746          Gsum             ! Gsum(n) = sum of areas in categories 0 to n 
    747  
    748       REAL(wp) ::    & 
    749          hi,         &    ! ice thickness for each cat (m) 
    750          hrmean           ! mean ridge thickness (m) 
    751  
    752       REAL(wp), DIMENSION(jpi,jpj) :: & 
    753          zworka            ! temporary array used here 
    754  
    755       REAL(wp)            ::   zdummy 
    756  
     699      INTEGER ::   ji,jj, jl    ! dummy loop indices 
     700      INTEGER ::   krdg_index   !  
     701 
     702      REAL(wp) ::   Gstari, astari, hi, hrmean, zdummy   ! local scalar 
     703 
     704      REAL(wp), DIMENSION(jpi,jpj,-1:jpl) ::   Gsum   ! Gsum(n) = sum of areas in categories 0 to n 
     705 
     706      REAL(wp), DIMENSION(jpi,jpj) ::   zworka            ! temporary array used here 
    757707      !------------------------------------------------------------------------------! 
    758708 
    … …  
    785735      ! initial value (in h = 0) equals open water area 
    786736 
    787       Gsum(:,:,-1) = 0.0 
     737      Gsum(:,:,-1) = 0._wp 
    788738 
    789739      DO jj = 1, jpj 
    790740         DO ji = 1, jpi 
    791             IF (ato_i(ji,jj) .GT. epsi11) THEN 
    792                Gsum(ji,jj,0) = ato_i(ji,jj) 
    793             ELSE 
    794                Gsum(ji,jj,0) = 0.0 
     741            IF( ato_i(ji,jj) > epsi11 ) THEN   ;   Gsum(ji,jj,0) = ato_i(ji,jj) 
     742            ELSE                               ;   Gsum(ji,jj,0) = 0._wp 
    795743            ENDIF 
    796744         END DO 
    … …  
    801749         DO jj = 1, jpj  
    802750            DO ji = 1, jpi 
    803                IF ( a_i(ji,jj,jl) .GT. epsi11 ) THEN 
    804                   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) + a_i(ji,jj,jl) 
    805                ELSE 
    806                   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) 
     751               IF( a_i(ji,jj,jl) .GT. epsi11 ) THEN   ;   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) + a_i(ji,jj,jl) 
     752               ELSE                                   ;   Gsum(ji,jj,jl) = Gsum(ji,jj,jl-1) 
    807753               ENDIF 
    808754            END DO 
    … …  
    811757 
    812758      ! Normalize the cumulative distribution to 1 
    813       DO jj = 1, jpj  
    814          DO ji = 1, jpi 
    815             zworka(ji,jj) = 1.0 / Gsum(ji,jj,jpl) 
    816          END DO 
    817       END DO 
    818  
     759      zworka(:,:) = 1._wp / Gsum(:,:,jpl) 
    819760      DO jl = 0, jpl 
    820          DO jj = 1, jpj  
    821             DO ji = 1, jpi 
    822                Gsum(ji,jj,jl) = Gsum(ji,jj,jl) * zworka(ji,jj) 
    823             END DO 
    824          END DO 
     761         Gsum(:,:,jl) = Gsum(:,:,jl) * zworka(:,:) 
    825762      END DO 
    826763 
    … …  
    839776      krdg_index = 1 
    840777 
    841       IF ( krdg_index .EQ. 0 ) THEN 
    842  
    843          !--- Linear formulation (Thorndike et al., 1975) 
    844          DO jl = 0, ice_cat_bounds(1,2) ! only undeformed ice participates 
     778      IF( krdg_index == 0 ) THEN       !--- Linear formulation (Thorndike et al., 1975) 
     779         DO jl = 0, ice_cat_bounds(1,2)       ! only undeformed ice participates 
    845780            DO jj = 1, jpj  
    846781               DO ji = 1, jpi 
    847                   IF (Gsum(ji,jj,jl) < Gstar) THEN 
     782                  IF( Gsum(ji,jj,jl) < Gstar) THEN 
    848783                     athorn(ji,jj,jl) = Gstari * (Gsum(ji,jj,jl)-Gsum(ji,jj,jl-1)) * & 
    849784                        (2.0 - (Gsum(ji,jj,jl-1)+Gsum(ji,jj,jl))*Gstari) 
    … …  
    858793         END DO ! jl  
    859794 
    860       ELSE ! krdg_index = 1 
    861  
    862          !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
    863          ! precompute exponential terms using Gsum as a work array 
    864          zdummy = 1.0 / (1.0-EXP(-astari)) 
     795      ELSE                             !--- Exponential, more stable formulation (Lipscomb et al, 2007) 
     796         !                         
     797         zdummy = 1._wp / ( 1._wp - EXP(-astari) )        ! precompute exponential terms using Gsum as a work array 
    865798 
    866799         DO jl = -1, jpl 
    867             DO jj = 1, jpj 
    868                DO ji = 1, jpi 
    869                   Gsum(ji,jj,jl) = EXP(-Gsum(ji,jj,jl)*astari)*zdummy 
    870                END DO !ji 
    871             END DO !jj 
     800            Gsum(:,:,jl) = EXP( -Gsum(:,:,jl) * astari ) * zdummy 
    872801         END DO !jl 
    873  
    874          ! compute athorn 
    875802         DO jl = 0, ice_cat_bounds(1,2) 
    876             DO jj = 1, jpj 
    877                DO ji = 1, jpi 
    878                   athorn(ji,jj,jl) = Gsum(ji,jj,jl-1) - Gsum(ji,jj,jl) 
    879                END DO !ji 
    880             END DO ! jj 
    881          END DO !jl 
    882  
     803             athorn(:,:,jl) = Gsum(:,:,jl-1) - Gsum(:,:,jl) 
     804         END DO 
     805         ! 
    883806      ENDIF ! krdg_index 
    884807 
    885       ! Ridging and rafting ice participation functions 
    886       IF ( raftswi .EQ. 1 ) THEN 
    887  
     808      IF( raftswi == 1 ) THEN      ! Ridging and rafting ice participation functions 
     809         ! 
    888810         DO jl = 1, jpl 
    889811            DO jj = 1, jpj  
    890812               DO ji = 1, jpi 
    891                   IF ( athorn(ji,jj,jl) .GT. 0.0 ) THEN 
    892                      aridge(ji,jj,jl) = ( TANH ( Craft * ( ht_i(ji,jj,jl) - & 
    893                         hparmeter ) ) + 1.0 ) / 2.0 * &  
    894                         athorn(ji,jj,jl) 
    895                      araft (ji,jj,jl) = ( TANH ( - Craft * ( ht_i(ji,jj,jl) - & 
    896                         hparmeter ) ) + 1.0 ) / 2.0 * & 
    897                         athorn(ji,jj,jl) 
    898                      IF ( araft(ji,jj,jl) .LT. epsi06 ) araft(ji,jj,jl)  = 0.0 
    899                      aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0) 
     813                  IF ( athorn(ji,jj,jl) .GT. 0._wp ) THEN 
     814!!gm  TANH( -X ) = - TANH( X )  so can be computed only 1 time.... 
     815                     aridge(ji,jj,jl) = ( TANH (  Craft * ( ht_i(ji,jj,jl) - hparmeter ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
     816                     araft (ji,jj,jl) = ( TANH ( -Craft * ( ht_i(ji,jj,jl) - hparmeter ) ) + 1.0 ) * 0.5 * athorn(ji,jj,jl) 
     817                     IF ( araft(ji,jj,jl) < epsi06 )   araft(ji,jj,jl)  = 0._wp 
     818                     aridge(ji,jj,jl) = MAX( athorn(ji,jj,jl) - araft(ji,jj,jl), 0.0 ) 
    900819                  ENDIF ! athorn 
    901820               END DO ! ji 
    … …  
    904823 
    905824      ELSE  ! raftswi = 0 
    906  
     825         ! 
    907826         DO jl = 1, jpl 
    908             DO jj = 1, jpj  
    909                DO ji = 1, jpi 
    910                   aridge(ji,jj,jl) = 1.0*athorn(ji,jj,jl) 
    911                END DO 
    912             END DO 
    913          END DO 
    914  
     827            aridge(:,:,jl) = athorn(:,:,jl) 
     828         END DO 
     829         ! 
    915830      ENDIF 
    916831 
    917       IF ( raftswi .EQ. 1 ) THEN 
     832      IF ( raftswi == 1 ) THEN 
    918833 
    919834         IF( MAXVAL(aridge + araft - athorn(:,:,1:jpl)) .GT. epsi11 ) THEN 
    … …  
    987902 
    988903      ! Normalization factor : aksum, ensures mass conservation 
    989       DO jj = 1, jpj 
    990          DO ji = 1, jpi 
    991             aksum(ji,jj) = athorn(ji,jj,0) 
    992          END DO 
     904      aksum(:,:) = athorn(ji,jj,0) 
     905      DO jl = 1, jpl  
     906         aksum(:,:)    = aksum(:,:) + aridge(:,:,jl) * ( 1._wp - 1._wp / krdg(:,:,jl) )    & 
     907            &                       + araft (:,:,jl) * ( 1._wp - 1._wp / kraft        ) 
    993908      END DO 
    994  
    995       DO jl = 1, jpl  
    996          DO jj = 1, jpj 
    997             DO ji = 1, jpi 
    998                aksum(ji,jj)    = aksum(ji,jj)                          & 
    999                   + aridge(ji,jj,jl) * (1.0 - 1.0/krdg(ji,jj,jl))    & 
    1000                   + araft (ji,jj,jl) * (1.0 - 1.0/kraft) 
    1001             END DO 
    1002          END DO 
    1003       END DO 
    1004  
     909      ! 
    1005910   END SUBROUTINE lim_itd_me_ridgeprep 
    1006911 
    1007912 
    1008913   SUBROUTINE lim_itd_me_ridgeshift( opning, closing_gross, msnow_mlt, esnow_mlt ) 
    1009       !!----------------------------------------------------------------------------- 
     914      !!---------------------------------------------------------------------- 
    1010915      !!                ***  ROUTINE lim_itd_me_icestrength *** 
    1011       !! ** Purpose : 
    1012       !!        This routine shift ridging ice among thickness categories 
    1013       !!                      of ice thickness 
    1014       !! 
    1015       !! ** Method  : 
    1016       !! Remove area, volume, and energy from each ridging category 
    1017       !! and add to thicker ice categories. 
    1018       !! 
    1019       !!----------------------------------------------------------------------------- 
    1020       REAL (wp), DIMENSION(jpi,jpj), INTENT(IN)   :: & 
    1021          opning,         & ! rate of opening due to divergence/shear 
    1022          closing_gross     ! rate at which area removed, not counting 
    1023       ! area of new ridges 
    1024  
    1025       REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: & 
    1026          msnow_mlt,     & ! mass of snow added to ocean (kg m-2) 
    1027          esnow_mlt        ! energy needed to melt snow in ocean (J m-2) 
    1028  
    1029       INTEGER :: & 
    1030          ji, jj, &         ! horizontal indices 
    1031          jl, jl1, jl2, &   ! thickness category indices 
    1032          jk,           &   ! ice layer index 
    1033          ij,           &   ! horizontal index, combines i and j loops 
    1034          icells            ! number of cells with aicen > puny 
    1035  
    1036       INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 
    1037          indxi, indxj      ! compressed indices 
    1038  
    1039       REAL(wp), DIMENSION(jpi,jpj) ::          & 
    1040          vice_init, vice_final, &  ! ice volume summed over categories 
    1041          eice_init, eice_final     ! ice energy summed over layers 
    1042  
    1043       REAL(wp), DIMENSION(jpi,jpj,jpl) ::      & 
    1044          aicen_init,            &  ! ice area before ridging 
    1045          vicen_init,            &  ! ice volume before ridging 
    1046          vsnon_init,            &  ! snow volume before ridging 
    1047          esnon_init,            &  ! snow energy before ridging 
    1048          smv_i_init,            &  ! ice salinity before ridging 
    1049          oa_i_init                 ! ice age before ridging 
    1050  
    1051       REAL(wp), DIMENSION(jpi,jpj,jkmax,jpl) :: & 
    1052          eicen_init        ! ice energy before ridging 
    1053  
    1054       REAL(wp), DIMENSION(jpi,jpj) ::           & 
    1055          afrac      , &     ! fraction of category area ridged 
    1056          ardg1      , &     ! area of ice ridged 
    1057          ardg2      , &     ! area of new ridges 
    1058          vsrdg      , &     ! snow volume of ridging ice 
    1059          esrdg      , &     ! snow energy of ridging ice 
    1060          oirdg1     , &     ! areal age content of ridged ice 
    1061          oirdg2     , &     ! areal age content of ridging ice 
    1062          dhr        , &     ! hrmax - hrmin 
    1063          dhr2       , &     ! hrmax^2 - hrmin^2 
    1064          fvol               ! fraction of new ridge volume going to n2 
    1065  
    1066       REAL(wp), DIMENSION(jpi,jpj) :: & 
    1067          vrdg1      , &     ! volume of ice ridged 
    1068          vrdg2      , &     ! volume of new ridges 
    1069          vsw        , &     ! volume of seawater trapped into ridges 
    1070          srdg1      , &     ! sal*volume of ice ridged 
    1071          srdg2      , &     ! sal*volume of new ridges 
    1072          smsw               ! sal*volume of water trapped into ridges 
    1073  
    1074       REAL(wp), DIMENSION(jpi,jpj) ::           & 
    1075          afrft      , &     ! fraction of category area rafted 
    1076          arft1      , &     ! area of ice rafted 
    1077          arft2      , &     ! area of new rafted zone 
    1078          virft      , &     ! ice volume of rafting ice 
    1079          vsrft      , &     ! snow volume of rafting ice 
    1080          esrft      , &     ! snow energy of rafting ice 
    1081          smrft      , &     ! salinity of rafting ice 
    1082          oirft1     , &     ! areal age content of rafted ice 
    1083          oirft2             ! areal age content of rafting ice 
    1084  
    1085       REAL(wp), DIMENSION(jpi,jpj,jkmax) ::    & 
    1086          eirft      , &     ! ice energy of rafting ice 
    1087          erdg1      , &     ! enth*volume of ice ridged 
    1088          erdg2      , &     ! enth*volume of new ridges 
    1089          ersw               ! enth of water trapped into ridges 
    1090  
    1091       REAL(wp) ::     & 
    1092          hL, hR     , &    ! left and right limits of integration 
    1093          farea      , &    ! fraction of new ridge area going to n2 
    1094          zdummy     , &    ! dummy argument 
    1095          zdummy0    , &    ! dummy argument 
    1096          ztmelts           ! ice melting point 
    1097  
    1098       REAL(wp) ::   zsrdg2 
    1099  
    1100       CHARACTER (len=80) :: & 
    1101          fieldid           ! field identifier 
    1102  
    1103       LOGICAL, PARAMETER :: & 
    1104          l_conservation_check = .true.  ! if true, check conservation  
    1105       ! (useful for debugging) 
    1106       LOGICAL ::         & 
    1107          neg_ato_i     , &  ! flag for ato_i(i,j) < -puny 
    1108          large_afrac   , &  ! flag for afrac > 1 
    1109          large_afrft        ! flag for afrac > 1 
    1110  
    1111       REAL(wp) ::        & 
    1112          zeps          , & 
    1113          zindb              ! switch for the presence of ridge poros or not 
    1114  
    1115       !---------------------------------------------------------------------------- 
     916      !! 
     917      !! ** Purpose :   shift ridging ice among thickness categories of ice thickness 
     918      !! 
     919      !! ** Method  :   Remove area, volume, and energy from each ridging category 
     920      !!              and add to thicker ice categories. 
     921      !!---------------------------------------------------------------------- 
     922      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   opning         ! rate of opening due to divergence/shear 
     923      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   closing_gross  ! rate at which area removed, excluding area of new ridges 
     924      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   msnow_mlt      ! mass of snow added to ocean (kg m-2) 
     925      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) ::   esnow_mlt      ! energy needed to melt snow in ocean (J m-2) 
     926      ! 
     927      CHARACTER (len=80) ::   fieldid   ! field identifier 
     928      LOGICAL, PARAMETER ::   l_conservation_check = .true.  ! if true, check conservation (useful for debugging) 
     929      ! 
     930      LOGICAL ::   neg_ato_i      ! flag for ato_i(i,j) < -puny 
     931      LOGICAL ::   large_afrac    ! flag for afrac > 1 
     932      LOGICAL ::   large_afrft    ! flag for afrac > 1 
     933      INTEGER ::   ji, jj, jl, jl1, jl2, jk   ! dummy loop indices 
     934      INTEGER ::   ij                ! horizontal index, combines i and j loops 
     935      INTEGER ::   icells            ! number of cells with aicen > puny 
     936      REAL(wp) ::   zeps, zindb, zsrdg2   ! local scalar 
     937      REAL(wp) ::   hL, hR, farea, zdummy, zdummy0, ztmelts    ! left and right limits of integration 
     938 
     939      INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) ::   indxi, indxj   ! compressed indices 
     940 
     941      REAL(wp), DIMENSION(jpi,jpj) ::   vice_init, vice_final   ! ice volume summed over categories 
     942      REAL(wp), DIMENSION(jpi,jpj) ::   eice_init, eice_final   ! ice energy summed over layers 
     943 
     944      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   aicen_init, vicen_init   ! ice  area    & volume before ridging 
     945      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   vsnon_init, esnon_init   ! snow volume  & energy before ridging 
     946      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   smv_i_init, oa_i_init    ! ice salinity & age    before ridging 
     947 
     948      REAL(wp), DIMENSION(jpi,jpj,jkmax,jpl) ::   eicen_init        ! ice energy before ridging 
     949 
     950      REAL(wp), DIMENSION(jpi,jpj) ::   afrac , fvol     ! fraction of category area ridged & new ridge volume going to n2 
     951      REAL(wp), DIMENSION(jpi,jpj) ::   ardg1 , ardg2    ! area of ice ridged & new ridges 
     952      REAL(wp), DIMENSION(jpi,jpj) ::   vsrdg , esrdg    ! snow volume & energy of ridging ice 
     953      REAL(wp), DIMENSION(jpi,jpj) ::   oirdg1, oirdg2   ! areal age content of ridged & rifging ice 
     954      REAL(wp), DIMENSION(jpi,jpj) ::   dhr   , dhr2     ! hrmax - hrmin  &  hrmax^2 - hrmin^2 
     955 
     956      REAL(wp), DIMENSION(jpi,jpj) ::   vrdg1   ! volume of ice ridged 
     957      REAL(wp), DIMENSION(jpi,jpj) ::   vrdg2   ! volume of new ridges 
     958      REAL(wp), DIMENSION(jpi,jpj) ::   vsw     ! volume of seawater trapped into ridges 
     959      REAL(wp), DIMENSION(jpi,jpj) ::   srdg1   ! sal*volume of ice ridged 
     960      REAL(wp), DIMENSION(jpi,jpj) ::   srdg2   ! sal*volume of new ridges 
     961      REAL(wp), DIMENSION(jpi,jpj) ::   smsw    ! sal*volume of water trapped into ridges 
     962 
     963      REAL(wp), DIMENSION(jpi,jpj) ::   afrft            ! fraction of category area rafted 
     964      REAL(wp), DIMENSION(jpi,jpj) ::   arft1 , arft2    ! area of ice rafted and new rafted zone 
     965      REAL(wp), DIMENSION(jpi,jpj) ::   virft , vsrft    ! ice & snow volume of rafting ice 
     966      REAL(wp), DIMENSION(jpi,jpj) ::   esrft , smrft    ! snow energy & salinity of rafting ice 
     967      REAL(wp), DIMENSION(jpi,jpj) ::   oirft1, oirft2   ! areal age content of rafted ice & rafting ice 
     968 
     969      REAL(wp), DIMENSION(jpi,jpj,jkmax) ::   eirft      ! ice energy of rafting ice 
     970      REAL(wp), DIMENSION(jpi,jpj,jkmax) ::   erdg1      ! enth*volume of ice ridged 
     971      REAL(wp), DIMENSION(jpi,jpj,jkmax) ::   erdg2      ! enth*volume of new ridges 
     972      REAL(wp), DIMENSION(jpi,jpj,jkmax) ::   ersw       ! enth of water trapped into ridges 
     973   !!---------------------------------------------------------------------- 
    1116974 
    1117975      ! Conservation check 
    1118       eice_init(:,:) = 0.0  
    1119  
    1120       IF ( con_i ) THEN 
     976      eice_init(:,:) = 0._wp 
     977 
     978      IF( con_i ) THEN 
    1121979         CALL lim_column_sum (jpl,   v_i, vice_init ) 
    1122980         WRITE(numout,*) ' vice_init  : ', vice_init(jiindx,jjindx) 
    … …  
    1125983      ENDIF 
    1126984 
    1127       zeps   = 1.0d-20 
     985      zeps   = 1.e-20_wp 
    1128986 
    1129987      !------------------------------------------------------------------------------- 
    … …  
    1135993      DO jj = 1, jpj 
    1136994         DO ji = 1, jpi 
    1137             ato_i(ji,jj) = ato_i(ji,jj)                                   & 
    1138                - athorn(ji,jj,0)*closing_gross(ji,jj)*rdt_ice        & 
    1139                + opning(ji,jj)*rdt_ice 
    1140             IF (ato_i(ji,jj) .LT. -epsi11) THEN 
    1141                neg_ato_i = .true. 
    1142             ELSEIF (ato_i(ji,jj) .LT. 0.0) THEN    ! roundoff error 
    1143                ato_i(ji,jj) = 0.0 
     995            ato_i(ji,jj) = ato_i(ji,jj) - athorn(ji,jj,0) * closing_gross(ji,jj) * rdt_ice        & 
     996               &                        + opning(ji,jj)                          * rdt_ice 
     997            IF( ato_i(ji,jj) < -epsi11 ) THEN 
     998               neg_ato_i = .TRUE. 
     999            ELSEIF( ato_i(ji,jj) < 0._wp ) THEN    ! roundoff error 
     1000               ato_i(ji,jj) = 0._wp 
    11441001            ENDIF 
    11451002         END DO !jj 
    … …  
    11471004 
    11481005      ! if negative open water area alert it 
    1149       IF (neg_ato_i) THEN       ! there is a bug 
     1006      IF( neg_ato_i ) THEN       ! there is a bug 
    11501007         DO jj = 1, jpj  
    11511008            DO ji = 1, jpi 
    1152                IF (ato_i(ji,jj) .LT. -epsi11) THEN  
     1009               IF( ato_i(ji,jj) < -epsi11 ) THEN  
    11531010                  WRITE(numout,*) ''   
    11541011                  WRITE(numout,*) 'Ridging error: ato_i < 0' 
    11551012                  WRITE(numout,*) 'ato_i : ', ato_i(ji,jj) 
    11561013               ENDIF               ! ato_i < -epsi11 
    1157             END DO              ! ji 
    1158          END DO                 ! jj 
    1159       ENDIF                     ! neg_ato_i 
     1014            END DO 
     1015         END DO 
     1016      ENDIF 
    11601017 
    11611018      !----------------------------------------------------------------- 
    … …  
    11641021 
    11651022      DO jl = 1, jpl 
    1166          DO jj = 1, jpj 
    1167             DO ji = 1, jpi 
    1168                aicen_init(ji,jj,jl) = a_i(ji,jj,jl) 
    1169                vicen_init(ji,jj,jl) = v_i(ji,jj,jl) 
    1170                vsnon_init(ji,jj,jl) = v_s(ji,jj,jl) 
    1171  
    1172                smv_i_init(ji,jj,jl) = smv_i(ji,jj,jl) 
    1173                oa_i_init (ji,jj,jl) = oa_i(ji,jj,jl) 
    1174             END DO !ji 
    1175          END DO ! jj 
     1023         aicen_init(:,:,jl) = a_i(:,:,jl) 
     1024         vicen_init(:,:,jl) = v_i(:,:,jl) 
     1025         vsnon_init(:,:,jl) = v_s(:,:,jl) 
     1026         ! 
     1027         smv_i_init(:,:,jl) = smv_i(:,:,jl) 
     1028         oa_i_init (:,:,jl) = oa_i (:,:,jl) 
    11761029      END DO !jl 
    11771030 
    … …  
    11801033      DO jl = 1, jpl   
    11811034         DO jk = 1, nlay_i 
    1182             DO jj = 1, jpj 
    1183                DO ji = 1, jpi 
    1184                   eicen_init(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) 
    1185                END DO !ji 
    1186             END DO !jj 
    1187          END DO !jk 
    1188       END DO !jl 
     1035            eicen_init(:,:,jk,jl) = e_i(:,:,jk,jl) 
     1036         END DO 
     1037      END DO 
    11891038 
    11901039      ! 
    … …  
    12571106            !     / rafting category n1. 
    12581107            !-------------------------------------------------------------------------- 
    1259             vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) /             & 
    1260                ( 1.0 + ridge_por ) 
     1108            vrdg1(ji,jj) = vicen_init(ji,jj,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por ) 
    12611109            vrdg2(ji,jj) = vrdg1(ji,jj) * ( 1. + ridge_por ) 
    12621110            vsw  (ji,jj) = vrdg1(ji,jj) * ridge_por 
    … …  
    12641112            vsrdg(ji,jj) = vsnon_init(ji,jj,jl1) * afrac(ji,jj) 
    12651113            esrdg(ji,jj) = esnon_init(ji,jj,jl1) * afrac(ji,jj) 
    1266             srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) /            & 
    1267                ( 1. + ridge_por ) 
     1114            srdg1(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por ) 
    12681115            srdg2(ji,jj) = smv_i_init(ji,jj,jl1) * afrac(ji,jj) 
    12691116 
    … …  
    13041151            !           ij looping 1-icells 
    13051152 
    1306             dardg1dt(ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) 
    1307             dardg2dt(ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj) 
     1153            dardg1dt   (ji,jj) = dardg1dt(ji,jj) + ardg1(ji,jj) + arft1(ji,jj) 
     1154            dardg2dt   (ji,jj) = dardg2dt(ji,jj) + ardg2(ji,jj) + arft2(ji,jj) 
    13081155            diag_dyn_gr(ji,jj) = diag_dyn_gr(ji,jj) + ( vrdg2(ji,jj) + virft(ji,jj) ) / rdt_ice 
    1309             opening(ji,jj) = opening (ji,jj) + opning(ji,jj)*rdt_ice 
    1310  
    1311             IF (con_i) vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 
     1156            opening    (ji,jj) = opening (ji,jj) + opning(ji,jj)*rdt_ice 
     1157 
     1158            IF( con_i )  vice_init(ji,jj) = vice_init(ji,jj) + vrdg2(ji,jj) - vrdg1(ji,jj) 
    13121159 
    13131160            !------------------------------------------             
    … …  
    13231170            !           ij looping 1-icells 
    13241171 
    1325             msnow_mlt(ji,jj) = msnow_mlt(ji,jj)                  & 
    1326                + rhosn*vsrdg(ji,jj)*(1.0-fsnowrdg)   & 
    1327                                 !rafting included 
    1328                + rhosn*vsrft(ji,jj)*(1.0-fsnowrft) 
    1329  
    1330             esnow_mlt(ji,jj) = esnow_mlt(ji,jj)                  & 
    1331                + esrdg(ji,jj)*(1.0-fsnowrdg)         & 
    1332                                 !rafting included 
    1333                + esrft(ji,jj)*(1.0-fsnowrft)           
     1172            msnow_mlt(ji,jj) = msnow_mlt(ji,jj) + rhosn*vsrdg(ji,jj)*(1.0-fsnowrdg)   &   ! rafting included 
     1173               &                                + rhosn*vsrft(ji,jj)*(1.0-fsnowrft) 
     1174 
     1175            esnow_mlt(ji,jj) = esnow_mlt(ji,jj) + esrdg(ji,jj)*(1.0-fsnowrdg)         &   !rafting included 
     1176               &                                + esrft(ji,jj)*(1.0-fsnowrft)           
    13341177 
    13351178            !----------------------------------------------------------------- 
    … …  
    13421185 
    13431186            dhr(ji,jj)  = hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) 
    1344             dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1)    & 
    1345                - hrmin(ji,jj,jl1)   * hrmin(ji,jj,jl1) 
     1187            dhr2(ji,jj) = hrmax(ji,jj,jl1) * hrmax(ji,jj,jl1) - hrmin(ji,jj,jl1) * hrmin(ji,jj,jl1) 
    13461188 
    13471189 
    … …  
    13581200               jj = indxj(ij) 
    13591201               ! heat content of ridged ice 
    1360                erdg1(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) / &  
    1361                   ( 1.0 + ridge_por )  
     1202               erdg1(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrac(ji,jj) / ( 1._wp + ridge_por )  
    13621203               eirft(ji,jj,jk)      = eicen_init(ji,jj,jk,jl1) * afrft(ji,jj) 
    1363                e_i(ji,jj,jk,jl1)    = e_i(ji,jj,jk,jl1)             & 
    1364                   - erdg1(ji,jj,jk)        & 
    1365                   - eirft(ji,jj,jk) 
     1204               e_i  (ji,jj,jk,jl1)  = e_i(ji,jj,jk,jl1) - erdg1(ji,jj,jk) - eirft(ji,jj,jk) 
    13661205               ! sea water heat content 
    13671206               ztmelts          = - tmut * sss_m(ji,jj) + rtt 
    … …  
    13701209 
    13711210               ! corrected sea water salinity 
    1372                zindb  = MAX( 0.0, SIGN( 1.0, vsw(ji,jj) - zeps ) ) 
    1373                zdummy = zindb * ( srdg1(ji,jj) - srdg2(ji,jj) ) / & 
    1374                   MAX( ridge_por * vsw(ji,jj), zeps ) 
     1211               zindb  = MAX( 0._wp , SIGN( 1._wp , vsw(ji,jj) - zeps ) ) 
     1212               zdummy = zindb * ( srdg1(ji,jj) - srdg2(ji,jj) ) / MAX( ridge_por * vsw(ji,jj), zeps ) 
    13751213 
    13761214               ztmelts          = - tmut * zdummy + rtt 
    … …  
    13781216 
    13791217               ! heat flux 
    1380                fheat_rpo(ji,jj) = fheat_rpo(ji,jj) + ( ersw(ji,jj,jk) - zdummy0 ) / & 
    1381                   rdt_ice 
     1218               fheat_rpo(ji,jj) = fheat_rpo(ji,jj) + ( ersw(ji,jj,jk) - zdummy0 ) / rdt_ice 
    13821219 
    13831220               ! Correct dimensions to avoid big values 
    1384                ersw(ji,jj,jk)   = ersw(ji,jj,jk) / 1.0d+09 
     1221               ersw(ji,jj,jk)   = ersw(ji,jj,jk) * 1.e-09 
    13851222 
    13861223               ! Mutliply by ice volume, and divide by number of layers to get heat content in 10^9 J 
    1387                ersw(ji,jj,jk)   = ersw(ji,jj,jk) * & 
    1388                   area(ji,jj) * vsw(ji,jj) / & 
    1389                   nlay_i 
     1224               ersw (ji,jj,jk)  = ersw(ji,jj,jk) * area(ji,jj) * vsw(ji,jj) / nlay_i 
    13901225 
    13911226               erdg2(ji,jj,jk)  = erdg1(ji,jj,jk) + ersw(ji,jj,jk) 
    … …  
    13941229 
    13951230 
    1396          IF ( con_i ) THEN 
     1231         IF( con_i ) THEN 
    13971232            DO jk = 1, nlay_i 
    13981233!CDIR NODEP 
    … …  
    14001235                  ji = indxi(ij) 
    14011236                  jj = indxj(ij) 
    1402                   eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - & 
    1403                      erdg1(ji,jj,jk) 
     1237                  eice_init(ji,jj) = eice_init(ji,jj) + erdg2(ji,jj,jk) - erdg1(ji,jj,jk) 
    14041238               END DO ! ij 
    14051239            END DO !jk 
    14061240         ENDIF 
    14071241 
    1408          IF (large_afrac) THEN  ! there is a bug 
     1242         IF( large_afrac ) THEN   ! there is a bug 
    14091243!CDIR NODEP 
    14101244            DO ij = 1, icells 
    14111245               ji = indxi(ij) 
    14121246               jj = indxj(ij) 
    1413                IF ( afrac(ji,jj) > 1.0 + epsi11 ) THEN  
     1247               IF( afrac(ji,jj) > 1.0 + epsi11 ) THEN  
    14141248                  WRITE(numout,*) '' 
    14151249                  WRITE(numout,*) ' ardg > a_i' 
    1416                   WRITE(numout,*) ' ardg, aicen_init : ', & 
    1417                      ardg1(ji,jj), aicen_init(ji,jj,jl1) 
    1418                ENDIF            ! afrac > 1 + puny 
    1419             ENDDO               ! if 
    1420          ENDIF                  ! large_afrac 
    1421          IF (large_afrft) THEN  ! there is a bug 
     1250                  WRITE(numout,*) ' ardg, aicen_init : ', ardg1(ji,jj), aicen_init(ji,jj,jl1) 
     1251               ENDIF 
     1252            END DO 
     1253         ENDIF 
     1254         IF( large_afrft ) THEN  ! there is a bug 
    14221255!CDIR NODEP 
    14231256            DO ij = 1, icells 
    14241257               ji = indxi(ij) 
    14251258               jj = indxj(ij) 
    1426                IF ( afrft(ji,jj) > 1.0 + epsi11 ) THEN  
     1259               IF( afrft(ji,jj) > 1.0 + epsi11 ) THEN  
    14271260                  WRITE(numout,*) '' 
    14281261                  WRITE(numout,*) ' arft > a_i' 
    1429                   WRITE(numout,*) ' arft, aicen_init : ', & 
    1430                      arft1(ji,jj), aicen_init(ji,jj,jl1) 
    1431                ENDIF            ! afrft > 1 + puny 
    1432             ENDDO               ! if 
    1433          ENDIF                  ! large_afrft 
     1262                  WRITE(numout,*) ' arft, aicen_init : ', arft1(ji,jj), aicen_init(ji,jj,jl1) 
     1263               ENDIF 
     1264            END DO 
     1265         ENDIF 
    14341266 
    14351267         !------------------------------------------------------------------------------- 
    … …  
    14611293               fvol(ji,jj) = (hR*hR - hL*hL) / dhr2(ji,jj) 
    14621294 
    1463                a_i(ji,jj,jl2)    = a_i(ji,jj,jl2) + farea * ardg2(ji,jj) 
    1464                v_i(ji,jj,jl2)    = v_i(ji,jj,jl2) + fvol(ji,jj) * vrdg2(ji,jj) 
    1465                v_s(ji,jj,jl2)    = v_s(ji,jj,jl2)                             & 
    1466                   + fvol(ji,jj) * vsrdg(ji,jj) * fsnowrdg 
    1467                e_s(ji,jj,1,jl2)  = e_s(ji,jj,1,jl2)                           & 
    1468                   + fvol(ji,jj) * esrdg(ji,jj) * fsnowrdg 
    1469                smv_i(ji,jj,jl2)  = smv_i(ji,jj,jl2) + fvol(ji,jj) * srdg2(ji,jj) 
    1470                oa_i(ji,jj,jl2)   = oa_i(ji,jj,jl2)  + farea * oirdg2(ji,jj) 
     1295               a_i  (ji,jj,jl2)   = a_i  (ji,jj,jl2)   + ardg2 (ji,jj) * farea 
     1296               v_i  (ji,jj,jl2)   = v_i  (ji,jj,jl2)   + vrdg2 (ji,jj) * fvol(ji,jj) 
     1297               v_s  (ji,jj,jl2)   = v_s  (ji,jj,jl2)   + vsrdg (ji,jj) * fvol(ji,jj) * fsnowrdg 
     1298               e_s  (ji,jj,1,jl2) = e_s  (ji,jj,1,jl2) + esrdg (ji,jj) * fvol(ji,jj) * fsnowrdg 
     1299               smv_i(ji,jj,jl2)   = smv_i(ji,jj,jl2)   + srdg2 (ji,jj) * fvol(ji,jj) 
     1300               oa_i (ji,jj,jl2)   = oa_i (ji,jj,jl2)   + oirdg2(ji,jj) * farea 
    14711301 
    14721302            END DO ! ij 
    … …  
    14781308                  ji = indxi(ij) 
    14791309                  jj = indxj(ij) 
    1480                   e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2)          & 
    1481                      + fvol(ji,jj)*erdg2(ji,jj,jk) 
    1482                END DO           ! ij 
    1483             END DO !jk 
    1484  
    1485  
     1310                  e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + fvol(ji,jj)*erdg2(ji,jj,jk) 
     1311               END DO 
     1312            END DO 
     1313            ! 
    14861314         END DO                 ! jl2 (new ridges)             
    14871315 
    1488          DO jl2  = ice_cat_bounds(1,1), ice_cat_bounds(1,2)  
     1316         DO jl2 = ice_cat_bounds(1,1), ice_cat_bounds(1,2)  
    14891317 
    14901318!CDIR NODEP 
    … …  
    14991327                  a_i(ji,jj,jl2) = a_i(ji,jj,jl2) + arft2(ji,jj) 
    15001328                  v_i(ji,jj,jl2) = v_i(ji,jj,jl2) + virft(ji,jj) 
    1501                   v_s(ji,jj,jl2) = v_s(ji,jj,jl2)                   & 
    1502                      + vsrft(ji,jj)*fsnowrft 
    1503                   e_s(ji,jj,1,jl2) = e_s(ji,jj,1,jl2)                   & 
    1504                      + esrft(ji,jj)*fsnowrft 
    1505                   smv_i(ji,jj,jl2) = smv_i(ji,jj,jl2)                 & 
    1506                      + smrft(ji,jj)     
    1507                   oa_i(ji,jj,jl2)  = oa_i(ji,jj,jl2)                  & 
    1508                      + oirft2(ji,jj)     
     1329                  v_s(ji,jj,jl2) = v_s(ji,jj,jl2) + vsrft(ji,jj)*fsnowrft 
     1330                  e_s(ji,jj,1,jl2) = e_s(ji,jj,1,jl2) + esrft(ji,jj)*fsnowrft 
     1331                  smv_i(ji,jj,jl2) = smv_i(ji,jj,jl2) + smrft(ji,jj)     
     1332                  oa_i(ji,jj,jl2)  = oa_i(ji,jj,jl2)  + oirft2(ji,jj)     
    15091333               ENDIF ! hraft 
    15101334 
    … …  
    15191343                  IF (hraft(ji,jj,jl1) .LE. hi_max(jl2) .AND.        & 
    15201344                     hraft(ji,jj,jl1) .GT. hi_max(jl2-1)) THEN 
    1521                      e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2)             & 
    1522                         + eirft(ji,jj,jk) 
     1345                     e_i(ji,jj,jk,jl2) = e_i(ji,jj,jk,jl2) + eirft(ji,jj,jk) 
    15231346                  ENDIF 
    15241347               END DO           ! ij 
    … …  
    15431366         WRITE(numout,*) ' eice_final : ', eice_final(jiindx,jjindx) 
    15441367      ENDIF 
    1545  
     1368      ! 
    15461369   END SUBROUTINE lim_itd_me_ridgeshift 
    15471370 
    … …  
    15501373      !!----------------------------------------------------------------------------- 
    15511374      !!                ***  ROUTINE lim_itd_me_asumr *** 
    1552       !! ** Purpose : 
    1553       !!        This routine finds total fractional area 
    1554       !! 
    1555       !! ** Method  : 
    1556       !! Find the total area of ice plus open water in each grid cell. 
    1557       !! 
    1558       !! This is similar to the aggregate_area subroutine except that the 
    1559       !! total area can be greater than 1, so the open water area is  
    1560       !! included in the sum instead of being computed as a residual.  
    1561       !! 
     1375      !! 
     1376      !! ** Purpose :   finds total fractional area 
     1377      !! 
     1378      !! ** Method  :   Find the total area of ice plus open water in each grid cell. 
     1379      !!              This is similar to the aggregate_area subroutine except that the 
     1380      !!              total area can be greater than 1, so the open water area is  
     1381      !!              included in the sum instead of being computed as a residual.  
    15621382      !!----------------------------------------------------------------------------- 
    15631383      INTEGER ::   jl   ! dummy loop index 
    … …  
    15651385      ! 
    15661386      asum(:,:) = ato_i(:,:)                    ! open water 
    1567       ! 
    15681387      DO jl = 1, jpl                            ! ice categories 
    15691388         asum(:,:) = asum(:,:) + a_i(:,:,jl) 
    … …  
    15851404      !! 
    15861405      !! ** input   :   Namelist namiceitdme 
    1587       !! 
    1588       !! history : 
    1589       !!  9.0, LIM3.0 - 02-2006 (M. Vancoppenolle) original code 
    15901406      !!------------------------------------------------------------------- 
    15911407      NAMELIST/namiceitdme/ ridge_scheme_swi, Cs, Cf, fsnowrdg, fsnowrft,&  
    … …  
    16301446      !! ** Purpose :   Remove too small sea ice areas and correct salt fluxes 
    16311447      !! 
    1632       !! 
    16331448      !! history : 
    16341449      !! author: William H. Lipscomb, LANL 
    … …  
    16381453      !!  9.0, LIM3.0 - 02-2006 (M. Vancoppenolle) original code 
    16391454      !!------------------------------------------------------------------- 
    1640       INTEGER ::   & 
    1641          ji,jj,  & ! horizontal indices 
    1642          jl,     & ! ice category index 
    1643          jk,     & ! ice layer index 
    1644          !           ij,     &   ! combined i/j horizontal index 
    1645          icells      ! number of cells with ice to zap 
    1646  
    1647       !      INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 
    1648       !           indxi,  & ! compressed indices for i/j directions 
    1649       !           indxj 
    1650  
    1651       INTEGER, DIMENSION(jpi,jpj) :: zmask 
    1652  
    1653  
    1654       REAL(wp) ::   xtmp      ! temporary variable 
     1455      INTEGER ::   ji, jj, jl, jk   ! dummy loop indices 
     1456      INTEGER ::   icells           ! number of cells with ice to zap 
     1457 
     1458      REAL(wp), DIMENSION(jpi,jpj) ::   zmask   ! 2D workspace 
     1459       
     1460!!gm      REAL(wp) ::   xtmp      ! temporary variable 
    16551461      !!------------------------------------------------------------------- 
    16561462 
    … …  
    16741480 
    16751481         icells = 0 
    1676          zmask = 0.e0 
     1482         zmask  = 0._wp 
    16771483         DO jj = 1, jpj 
    16781484            DO ji = 1, jpi 
    1679                IF ( ( a_i(ji,jj,jl) .GE. -epsi11 .AND. a_i(ji,jj,jl) .LT. 0.0)       & 
    1680                   .OR.                                         & 
    1681                   ( a_i(ji,jj,jl) .GT. 0.0     .AND. a_i(ji,jj,jl) .LE. 1.0e-11 )  & 
    1682                   .OR.                                         & 
    1683                                 !new line 
    1684                   ( v_i(ji,jj,jl) .EQ. 0.0     .AND. a_i(ji,jj,jl) .GT. 0.0    )   & 
    1685                   .OR.                                         & 
    1686                   ( v_i(ji,jj,jl) .GT. 0.0     .AND. v_i(ji,jj,jl) .LT. 1.e-12 ) ) THEN 
    1687                   zmask(ji,jj) = 1 
    1688                ENDIF 
    1689             END DO 
    1690          END DO 
    1691          IF( ln_nicep ) WRITE(numout,*) SUM(zmask), ' cells of ice zapped in the ocean ' 
     1485               IF(  ( a_i(ji,jj,jl) .GE. -epsi11 .AND. a_i(ji,jj,jl) .LT. 0._wp   ) .OR.   & 
     1486                  & ( a_i(ji,jj,jl) .GT. 0._wp   .AND. a_i(ji,jj,jl) .LE. 1.0e-11 ) .OR.   & 
     1487                  & ( v_i(ji,jj,jl)  ==  0._wp   .AND. a_i(ji,jj,jl) .GT. 0._wp   ) .OR.   & 
     1488                  & ( v_i(ji,jj,jl) .GT. 0._wp   .AND. v_i(ji,jj,jl) .LT. 1.e-12  )      )   zmask(ji,jj) = 1._wp 
     1489            END DO 
     1490         END DO 
     1491         IF( ln_nicep )   WRITE(numout,*) SUM(zmask), ' cells of ice zapped in the ocean ' 
    16921492 
    16931493         !----------------------------------------------------------------- 
    … …  
    16981498            DO jj = 1 , jpj 
    16991499               DO ji = 1 , jpi 
    1700  
    1701                   xtmp = e_i(ji,jj,jk,jl) / area(ji,jj) / rdt_ice 
    1702                   xtmp = xtmp * unit_fac 
    1703                   !              fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 
     1500!!gm                  xtmp = e_i(ji,jj,jk,jl) / area(ji,jj) / rdt_ice 
     1501!!gm                  xtmp = xtmp * unit_fac 
     1502                  ! fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 
    17041503                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * ( 1 - zmask(ji,jj) ) 
    1705                END DO           ! ji 
    1706             END DO           ! jj 
    1707          END DO           ! jk 
     1504               END DO 
     1505            END DO 
     1506         END DO 
    17081507 
    17091508         DO jj = 1 , jpj 
    … …  
    17131512               ! Zap snow energy and use ocean heat to melt snow 
    17141513               !----------------------------------------------------------------- 
    1715  
    17161514               !           xtmp = esnon(i,j,n) / dt ! < 0 
    17171515               !           fhnet(i,j)      = fhnet(i,j)      + xtmp 
    … …  
    17201518               ! fluxes are positive to the ocean 
    17211519               ! here the flux has to be negative for the ocean 
    1722                xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice 
     1520!!gm               xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice 
    17231521               !           fheat_res(ji,jj) = fheat_res(ji,jj) - xtmp 
    17241522 
    1725                xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice !RB   ??????? 
     1523!!gm               xtmp = ( rhosn*cpic*( rtt-t_s(ji,jj,1,jl) ) + rhosn*lfus ) / rdt_ice !RB   ??????? 
    17261524 
    17271525               t_s(ji,jj,1,jl) = rtt * zmask(ji,jj) + t_s(ji,jj,1,jl) * ( 1 - zmask(ji,jj) ) 
    … …  
    17441542               !           fsalt_hist(i,j) = fsalt_hist(i,j) + xtmp 
    17451543 
    1746                ato_i(ji,jj)   = a_i(ji,jj,jl)  * zmask(ji,jj) + ato_i(ji,jj) 
    1747                a_i(ji,jj,jl)  = a_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
    1748                v_i(ji,jj,jl)  = v_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
    1749                v_s(ji,jj,jl)  = v_s(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
    1750                t_su(ji,jj,jl) = t_su(ji,jj,jl) * (1 -zmask(ji,jj) ) + t_bo(ji,jj) * zmask(ji,jj) 
    1751                oa_i(ji,jj,jl) = oa_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
     1544               ato_i(ji,jj)    = a_i  (ji,jj,jl) *       zmask(ji,jj)  + ato_i(ji,jj) 
     1545               a_i  (ji,jj,jl) = a_i  (ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
     1546               v_i  (ji,jj,jl) = v_i  (ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
     1547               v_s  (ji,jj,jl) = v_s  (ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
     1548               t_su (ji,jj,jl) = t_su (ji,jj,jl) * ( 1 - zmask(ji,jj) ) + t_bo(ji,jj) * zmask(ji,jj) 
     1549               oa_i (ji,jj,jl) = oa_i (ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
    17521550               smv_i(ji,jj,jl) = smv_i(ji,jj,jl) * ( 1 - zmask(ji,jj) ) 
    1753  
    1754             END DO                 ! ji 
    1755          END DO                 ! jj 
    1756  
     1551               ! 
     1552            END DO 
     1553         END DO 
     1554         ! 
    17571555      END DO                 ! jl  
    17581556      ! 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limitd_th.F90

    r2528 r2612  
    55   !!                   computation of changes in g(h)       
    66   !!====================================================================== 
     7   !! History :   -   !          (W. H. Lipscomb and E.C. Hunke) CICE (c) original code 
     8   !!            3.0  ! 2005-12  (M. Vancoppenolle) adaptation to LIM-3 
     9   !!             -   ! 2006-06  (M. Vancoppenolle) adaptation to include salt, age and types 
     10   !!             -   ! 2007-04  (M. Vancoppenolle) Mass conservation checked 
     11   !!---------------------------------------------------------------------- 
    712#if defined key_lim3 
    813   !!---------------------------------------------------------------------- 
    914   !!   'key_lim3' :                                   LIM3 sea-ice model 
    1015   !!---------------------------------------------------------------------- 
     16   !!   lim_itd_th       : thermodynamics of ice thickness distribution 
     17   !!   lim_itd_th_rem   : 
     18   !!   lim_itd_th_reb   : 
     19   !!   lim_itd_fitline  : 
     20   !!   lim_itd_shiftice : 
    1121   !!---------------------------------------------------------------------- 
    12    USE dom_ice 
     22   USE dom_ice          ! LIM-3 domain 
    1323   USE par_oce          ! ocean parameters 
    14    USE dom_oce 
     24   USE dom_oce          ! ocean domain 
    1525   USE phycst           ! physical constants (ocean directory)  
    16    USE thd_ice 
    17    USE ice 
    18    USE par_ice 
    19    USE limthd_lac 
    20    USE limvar 
    21    USE limcons 
     26   USE thd_ice          ! LIM-3 thermodynamic variables 
     27   USE ice              ! LIM-3 variables 
     28   USE par_ice          ! LIM-3 parameters 
     29   USE limthd_lac       ! LIM-3 lateral accretion 
     30   USE limvar           ! LIM-3 variables 
     31   USE limcons          ! LIM-3 conservation 
    2232   USE prtctl           ! Print control 
    23    USE in_out_manager 
    24    USE lib_mpp  
     33   USE in_out_manager   ! I/O manager 
     34   USE lib_mpp          ! MPP library 
    2535 
    2636   IMPLICIT NONE 
    2737   PRIVATE 
    2838 
    29    PUBLIC lim_itd_th        ! called by ice_stp 
    30    PUBLIC lim_itd_th_rem 
    31    PUBLIC lim_itd_th_reb 
    32    PUBLIC lim_itd_fitline 
    33    PUBLIC lim_itd_shiftice 
    34  
    35    REAL(wp)  ::           &  ! constant values 
    36       epsi20 = 1e-20   ,  & 
    37       epsi13 = 1e-13   ,  & 
    38       zzero  = 0.e0    ,  & 
    39       zone   = 1.e0 
     39   PUBLIC   lim_itd_th        ! called by ice_stp 
     40   PUBLIC   lim_itd_th_rem 
     41   PUBLIC   lim_itd_th_reb 
     42   PUBLIC   lim_itd_fitline 
     43   PUBLIC   lim_itd_shiftice 
     44 
     45   REAL(wp) ::   epsi20 = 1e-20_wp   ! constant values 
     46   REAL(wp) ::   epsi13 = 1e-13_wp   ! 
     47   REAL(wp) ::   epsi10 = 1e-10_wp   ! 
    4048 
    4149   !!---------------------------------------------------------------------- 
    42    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     50   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2010) 
    4351   !! $Id$ 
    44    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     52   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4553   !!---------------------------------------------------------------------- 
    46  
    47  
    4854CONTAINS 
    4955 
    … …  
    5157      !!------------------------------------------------------------------ 
    5258      !!                ***  ROUTINE lim_itd_th *** 
    53       !! ** Purpose : 
    54       !!        This routine computes the thermodynamics of ice thickness 
    55       !!         distribution 
     59      !! 
     60      !! ** Purpose :   computes the thermodynamics of ice thickness distribution 
     61      !! 
    5662      !! ** Method  : 
    57       !! 
    58       !! ** Arguments : 
    59       !!           kideb , kiut : Starting and ending points on which the  
    60       !!                         the computation is applied 
    61       !! 
    62       !! ** Inputs / Ouputs : (global commons) 
    63       !! 
    64       !! ** External :  
    65       !! 
    66       !! ** References : 
    67       !! 
    68       !! ** History : 
    69       !!           (12-2005) Martin Vancoppenolle  
    70       !! 
    71       !!------------------------------------------------------------------ 
    72       !! * Arguments 
    73       INTEGER, INTENT(in) :: kt 
    74       !! * Local variables 
    75       INTEGER ::   jl, ja,   &   ! ice category, layers 
    76          jm,       &   ! ice types    dummy loop index 
    77          jbnd1,    & 
    78          jbnd2 
    79  
    80       REAL(wp)  ::           &  ! constant values 
    81          zeps      =  1.0e-10, & 
    82          epsi10    =  1.0e-10 
     63      !!------------------------------------------------------------------ 
     64      INTEGER, INTENT(in) ::   kt   ! time step index 
     65      ! 
     66      INTEGER ::   jl, ja, jm, jbnd1, jbnd2   ! ice types    dummy loop index          
     67 
     68      !!------------------------------------------------------------------ 
    8369 
    8470      IF( kt == nit000 .AND. lwp ) THEN 
    … …  
    9682         jbnd1 = ice_cat_bounds(jm,1) 
    9783         jbnd2 = ice_cat_bounds(jm,2) 
    98          IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_rem( jbnd1, jbnd2, jm, kt ) 
     84         IF( ice_ncat_types(jm) > 1 )  CALL lim_itd_th_rem( jbnd1, jbnd2, jm, kt ) 
    9985      END DO 
    100  
    101       CALL lim_var_glo2eqv ! only for info 
     86      ! 
     87      CALL lim_var_glo2eqv    ! only for info 
    10288      CALL lim_var_agg(1) 
    10389 
    … …  
    10793 
    10894      CALL lim_thd_lac 
    109       CALL lim_var_glo2eqv ! only for info 
     95      CALL lim_var_glo2eqv    ! only for info 
    11096 
    11197      !---------------------------------------------------------------------------------------- 
    … …  
    120106      d_e_i_thd(:,:,:,:) = e_i(:,:,:,:) - old_e_i(:,:,:,:) 
    121107 
    122       d_smv_i_thd(:,:,:) = 0.0 
    123       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 
    124          d_smv_i_thd(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 
     108      d_smv_i_thd(:,:,:) = 0._wp 
     109      IF( num_sal == 2 .OR. num_sal == 4 )   d_smv_i_thd(:,:,:) = smv_i(:,:,:) - old_smv_i(:,:,:) 
    125110 
    126111      IF(ln_ctl) THEN   ! Control print 
    … …  
    157142 
    158143      !- Recover Old values 
    159       a_i(:,:,:)         = old_a_i (:,:,:) 
    160       v_s(:,:,:)         = old_v_s (:,:,:) 
    161       v_i(:,:,:)         = old_v_i (:,:,:) 
    162       e_s(:,:,:,:)       = old_e_s (:,:,:,:) 
    163       e_i(:,:,:,:)       = old_e_i (:,:,:,:) 
    164  
    165       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 
    166          smv_i(:,:,:)       = old_smv_i (:,:,:) 
    167  
     144      a_i(:,:,:)   = old_a_i (:,:,:) 
     145      v_s(:,:,:)   = old_v_s (:,:,:) 
     146      v_i(:,:,:)   = old_v_i (:,:,:) 
     147      e_s(:,:,:,:) = old_e_s (:,:,:,:) 
     148      e_i(:,:,:,:) = old_e_i (:,:,:,:) 
     149      ! 
     150      IF( num_sal == 2 .OR. num_sal == 4 )   smv_i(:,:,:)       = old_smv_i (:,:,:) 
     151      ! 
    168152   END SUBROUTINE lim_itd_th 
    169153   ! 
    … …  
    172156      !!------------------------------------------------------------------ 
    173157      !!                ***  ROUTINE lim_itd_th_rem *** 
    174       !! ** Purpose : 
    175       !!        This routine computes the redistribution of ice thickness 
    176       !!        after thermodynamic growth of ice thickness 
     158      !! 
     159      !! ** Purpose :  computes the redistribution of ice thickness 
     160      !!              after thermodynamic growth of ice thickness 
    177161      !! 
    178162      !! ** Method  : Linear remapping  
    179163      !! 
    180       !! ** Arguments : 
    181       !!           klbnd, kubnd : Starting and ending category index on which the  
    182       !!                         the computation is applied 
    183       !! 
    184       !! ** Inputs / Ouputs : (global commons) 
    185       !! 
    186       !! ** External :  
    187       !! 
    188       !! ** References : W.H. Lipscomb, JGR 2001 
    189       !! 
    190       !! ** History : 
    191       !!           largely inspired from CICE (c) W. H. Lipscomb and E.C. Hunke 
    192       !!  
    193       !!           (01-2006) Martin Vancoppenolle, UCL-ASTR, translation from 
    194       !!                     CICE 
    195       !!           (06-2006) Adaptation to include salt, age and types 
    196       !!           (04-2007) Mass conservation checked 
    197       !!------------------------------------------------------------------ 
    198       !! * Arguments 
    199  
    200       INTEGER , INTENT (IN) ::  & 
    201          klbnd ,  &  ! Start thickness category index point 
    202          kubnd ,  &  ! End point on which the  the computation is applied 
    203          ntyp  ,  &  ! Number of the type used 
    204          kt          ! Ocean time step  
    205  
    206       !! * Local variables 
    207       INTEGER ::   ji,       &   ! spatial dummy loop index 
    208          jj,       &   ! spatial dummy loop index 
    209          jl,       &   ! ice category dummy loop index 
    210          zji, zjj, &   ! dummy indices used when changing coordinates 
    211          nd            ! used for thickness categories 
    212  
    213       INTEGER , DIMENSION(jpi,jpj,jpl-1) :: &  
    214          zdonor        ! donor category index 
    215  
    216       REAL(wp)  ::           &   ! constant values 
    217          zeps      =  1.0e-10 
    218  
    219       REAL(wp)  ::           &  ! constant values for ice enthalpy 
    220          zindb     ,         & 
    221          zareamin  ,         &  ! minimum tolerated area in a thickness category 
    222          zwk1, zwk2,         &  ! all the following are dummy arguments 
    223          zx1, zx2, zx3,      &  ! 
    224          zetamin   ,         &  ! minimum value of eta 
    225          zetamax   ,         &  ! maximum value of eta 
    226          zdh0      ,         &  !  
    227          zda0      ,         &  ! 
    228          zdamax    ,         &  ! 
    229          zhimin 
     164      !! References : W.H. Lipscomb, JGR 2001 
     165      !!------------------------------------------------------------------ 
     166      INTEGER , INTENT (in) ::   klbnd   ! Start thickness category index point 
     167      INTEGER , INTENT (in) ::   kubnd   ! End point on which the  the computation is applied 
     168      INTEGER , INTENT (in) ::   ntyp    ! Number of the type used 
     169      INTEGER , INTENT (in) ::   kt      ! Ocean time step  
     170      ! 
     171      INTEGER  ::   ji, jj, jl     ! dummy loop index 
     172      INTEGER  ::   zji, zjj, nd   ! local integer 
     173      REAL(wp) ::   zx1, zwk1, zdh0, zetamin, zdamax   ! local scalars 
     174      REAL(wp) ::   zx2, zwk2, zda0, zetamax, zhimin   !   -      - 
     175      REAL(wp) ::   zx3,             zareamin, zindb   !   -      - 
     176      CHARACTER (len = 15) :: fieldid 
     177 
     178      INTEGER , DIMENSION(jpi,jpj,jpl-1) ::   zdonor   ! donor category index 
    230179 
    231180      REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 
    … …  
    238187         dummy_es 
    239188 
    240       REAL(wp), DIMENSION(jpi,jpj,jpl-1) :: & 
    241          zdaice           ,  &  ! local increment of ice area  
    242          zdvice                 ! local increment of ice volume 
    243  
    244       REAL(wp), DIMENSION(jpi,jpj,0:jpl) :: & 
    245          zhbnew                 ! new boundaries of ice categories 
    246  
    247       REAL(wp), DIMENSION(jpi,jpj) :: & 
    248          zhb0, zhb1             ! category boundaries for thinnes categories 
    249  
    250       REAL, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 
    251          zvetamin, zvetamax     ! maximum values for etas 
    252  
    253       INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 
    254          nind_i      ,  &  ! compressed indices for i/j directions 
    255          nind_j 
    256  
    257       INTEGER :: & 
    258          nbrem             ! number of cells with ice to transfer 
    259  
    260       LOGICAL, DIMENSION(jpi,jpj) ::   &  !: 
    261          zremap_flag             ! compute remapping or not ???? 
    262  
    263       REAL(wp)  ::           &  ! constant values for ice enthalpy 
    264          zslope                 ! used to compute local thermodynamic "speeds" 
    265  
    266       REAL (wp), DIMENSION(jpi,jpj) :: &  !  
    267          vt_i_init, vt_i_final,   &  !  ice volume summed over categories 
    268          vt_s_init, vt_s_final,   &  !  snow volume summed over categories 
    269          et_i_init, et_i_final,   &  !  ice energy summed over categories 
    270          et_s_init, et_s_final       !  snow energy summed over categories 
    271  
    272       CHARACTER (len = 15) :: fieldid 
    273  
    274       !!-- End of declarations 
    275       !!---------------------------------------------------------------------------------------------- 
    276       zhimin = 0.1      !minimum ice thickness tolerated by the model 
    277       zareamin = zeps   !minimum area in thickness categories tolerated by the conceptors of the model 
     189      REAL(wp), DIMENSION(jpi,jpj,jpl-1) ::   zdaice, zdvice   ! local increment of ice area and volume 
     190 
     191      REAL(wp), DIMENSION(jpi,jpj,0:jpl) ::   zhbnew           ! new boundaries of ice categories 
     192 
     193 
     194      REAL, DIMENSION(1:(jpi+1)*(jpj+1)) ::   zvetamin, zvetamax     ! maximum values for etas 
     195 
     196      INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) ::   nind_i, nind_j  ! compressed indices for i/j directions 
     197 
     198      INTEGER ::   nbrem             ! number of cells with ice to transfer 
     199 
     200      LOGICAL, DIMENSION(jpi,jpj) ::   zremap_flag             ! compute remapping or not ???? 
     201 
     202      REAL(wp)  ::   zslope                 ! used to compute local thermodynamic "speeds" 
     203 
     204      REAL(wp), DIMENSION(jpi,jpj) ::   zhb0, zhb1             ! category boundaries for thinnes categories 
     205      REAL(wp), DIMENSION(jpi,jpj) ::   vt_i_init, vt_i_final   !  ice volume summed over categories 
     206      REAL(wp), DIMENSION(jpi,jpj) ::   vt_s_init, vt_s_final   !  snow volume summed over categories 
     207      REAL(wp), DIMENSION(jpi,jpj) ::   et_i_init, et_i_final   !  ice energy summed over categories 
     208      REAL(wp), DIMENSION(jpi,jpj) ::   et_s_init, et_s_final   !  snow energy summed over categories 
     209      !!------------------------------------------------------------------ 
     210 
     211      zhimin   = 0.1      !minimum ice thickness tolerated by the model 
     212      zareamin = epsi10   !minimum area in thickness categories tolerated by the conceptors of the model 
    278213 
    279214      !!---------------------------------------------------------------------------------------------- 
    280215      !! 0) Conservation checkand changes in each ice category 
    281216      !!---------------------------------------------------------------------------------------------- 
    282       IF ( con_i ) THEN 
     217      IF( con_i ) THEN 
    283218         CALL lim_column_sum (jpl,   v_i, vt_i_init) 
    284219         CALL lim_column_sum (jpl,   v_s, vt_s_init) 
    … …  
    291226      !! 1) Compute thickness and changes in each ice category 
    292227      !!---------------------------------------------------------------------------------------------- 
    293       IF (kt == nit000 .AND. lwp) THEN 
     228      IF( kt == nit000 .AND. lwp) THEN 
    294229         WRITE(numout,*) 
    295230         WRITE(numout,*) 'lim_itd_th_rem  : Remapping the ice thickness distribution' 
    … …  
    300235      ENDIF 
    301236 
    302       zdhice(:,:,:) = 0.0 
     237      zdhice(:,:,:) = 0._wp 
    303238      DO jl = klbnd, kubnd 
    304239         DO jj = 1, jpj 
    305240            DO ji = 1, jpi 
    306241               zindb             = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl)))     !0 if no ice and 1 if yes 
    307                ht_i(ji,jj,jl)    = v_i(ji,jj,jl) / MAX(a_i(ji,jj,jl),zeps) * zindb 
     242               ht_i(ji,jj,jl)    = v_i(ji,jj,jl) / MAX(a_i(ji,jj,jl),epsi10) * zindb 
    308243               zindb             = 1.0-MAX(0.0,SIGN(1.0,-old_a_i(ji,jj,jl))) !0 if no ice and 1 if yes 
    309                zht_i_o(ji,jj,jl) = old_v_i(ji,jj,jl) / MAX(old_a_i(ji,jj,jl),zeps) * zindb 
    310                IF (a_i(ji,jj,jl).gt.1e-6) THEN 
    311                   zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_o(ji,jj,jl)  
    312                ENDIF 
     244               zht_i_o(ji,jj,jl) = old_v_i(ji,jj,jl) / MAX(old_a_i(ji,jj,jl),epsi10) * zindb 
     245               IF( a_i(ji,jj,jl) > 1e-6 )   zdhice(ji,jj,jl) = ht_i(ji,jj,jl) - zht_i_o(ji,jj,jl)  
    313246            END DO 
    314247         END DO 
    … …  
    318251      !  2) Compute fractional ice area in each grid cell 
    319252      !----------------------------------------------------------------------------------------------- 
    320       at_i(:,:) = 0.0 
     253      at_i(:,:) = 0._wp 
    321254      DO jl = klbnd, kubnd 
    322          DO jj = 1, jpj 
    323             DO ji = 1, jpi 
    324                at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) 
    325             END DO 
    326          END DO 
     255         at_i(:,:) = at_i(:,:) + a_i(:,:,jl) 
    327256      END DO 
    328257 
    … …  
    351280      ! will be soon removed, CT 
    352281      ! hi_max(kubnd) = 999.99 
    353       zhbnew(:,:,:) = 0.0 
     282      zhbnew(:,:,:) = 0._wp 
    354283 
    355284      DO jl = klbnd, kubnd - 1 
    356          ! jl 
    357285         DO ji = 1, nbrem 
    358             ! jl, ji 
    359286            zji = nind_i(ji) 
    360287            zjj = nind_j(ji) 
    361288            ! 
    362             IF ( ( zht_i_o(zji,zjj,jl)  .GT.zeps ) .AND. &  
    363                ( zht_i_o(zji,zjj,jl+1).GT.zeps ) ) THEN 
     289            IF ( ( zht_i_o(zji,zjj,jl)  .GT.epsi10 ) .AND. &  
     290               ( zht_i_o(zji,zjj,jl+1).GT.epsi10 ) ) THEN 
    364291               !interpolate between adjacent category growth rates 
    365292               zslope = ( zdhice(zji,zjj,jl+1)     - zdhice(zji,zjj,jl) ) / & 
    … …  
    367294               zhbnew(zji,zjj,jl) = hi_max(jl) + zdhice(zji,zjj,jl) + & 
    368295                  zslope * ( hi_max(jl) - zht_i_o(zji,zjj,jl) ) 
    369             ELSEIF (zht_i_o(zji,zjj,jl).gt.zeps) THEN 
     296            ELSEIF (zht_i_o(zji,zjj,jl).gt.epsi10) THEN 
    370297               zhbnew(zji,zjj,jl) = hi_max(jl) + zdhice(zji,zjj,jl) 
    371             ELSEIF (zht_i_o(zji,zjj,jl+1).gt.zeps) THEN 
     298            ELSEIF (zht_i_o(zji,zjj,jl+1).gt.epsi10) THEN 
    372299               zhbnew(zji,zjj,jl) = hi_max(jl) + zdhice(zji,zjj,jl+1) 
    373300            ELSE 
    374301               zhbnew(zji,zjj,jl) = hi_max(jl) 
    375302            ENDIF 
    376             ! jl, ji 
    377          END DO !ji 
    378          ! jl 
     303         END DO 
    379304 
    380305         !- 4.2 Check that each zhbnew lies between adjacent values of ice thickness 
    … …  
    384309            zjj = nind_j(ji) 
    385310            ! jl, ji 
    386             IF ( ( a_i(zji,zjj,jl) .GT.zeps) .AND. &  
     311            IF ( ( a_i(zji,zjj,jl) .GT.epsi10) .AND. &  
    387312               ( ht_i(zji,zjj,jl).GE. zhbnew(zji,zjj,jl) ) & 
    388313               ) THEN 
    389314               zremap_flag(zji,zjj) = .false. 
    390             ELSEIF ( ( a_i(zji,zjj,jl+1) .GT. zeps ) .AND. & 
     315            ELSEIF ( ( a_i(zji,zjj,jl+1) .GT. epsi10 ) .AND. & 
    391316               ( ht_i(zji,zjj,jl+1).LE. zhbnew(zji,zjj,jl) ) & 
    392317               ) THEN 
    … …  
    430355            zhb1(ji,jj) = hi_max_typ(1,ntyp) ! 1er 
    431356 
    432             zhbnew(ji,jj,klbnd-1) = 0.0 
    433  
    434             IF ( a_i(ji,jj,kubnd) .GT. zeps ) THEN 
    435                zhbnew(ji,jj,kubnd) = 3.0*ht_i(ji,jj,kubnd) - 2.0*zhbnew(ji,jj,kubnd-1) 
     357            zhbnew(ji,jj,klbnd-1) = 0._wp 
     358 
     359            IF( a_i(ji,jj,kubnd) > epsi10 ) THEN 
     360               zhbnew(ji,jj,kubnd) = 3._wp * ht_i(ji,jj,kubnd) - 2._wp * zhbnew(ji,jj,kubnd-1) 
    436361            ELSE 
    437362               zhbnew(ji,jj,kubnd) = hi_max(kubnd) 
    438363            ENDIF 
    439364 
    440             IF ( zhbnew(ji,jj,kubnd) .LT. hi_max(kubnd-1) ) & 
    441                zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) 
     365            IF( zhbnew(ji,jj,kubnd) < hi_max(kubnd-1) )   zhbnew(ji,jj,kubnd) = hi_max(kubnd-1) 
    442366 
    443367         END DO !jj 
    … …  
    448372      !----------------------------------------------------------------------------------------------- 
    449373      !- 7.1 g(h) for category 1 at start of time step 
    450       CALL lim_itd_fitline(klbnd, zhb0, zhb1, zht_i_o(:,:,klbnd), & 
    451          g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd), & 
    452          hR(:,:,klbnd), zremap_flag) 
     374      CALL lim_itd_fitline( klbnd, zhb0, zhb1, zht_i_o(:,:,klbnd),        & 
     375         &                  g0(:,:,klbnd), g1(:,:,klbnd), hL(:,:,klbnd),  & 
     376         &                  hR(:,:,klbnd), zremap_flag ) 
    453377 
    454378      !- 7.2 Area lost due to melting of thin ice (first category,  klbnd) 
    … …  
    458382 
    459383         !ji 
    460          IF (a_i(zji,zjj,klbnd) .gt. zeps) THEN 
     384         IF (a_i(zji,zjj,klbnd) .gt. epsi10) THEN 
    461385            zdh0 = zdhice(zji,zjj,klbnd) !decrease of ice thickness in the lower category 
    462             ! ji, a_i > zeps 
     386            ! ji, a_i > epsi10 
    463387            IF (zdh0 .lt. 0.0) THEN !remove area from category 1 
    464                ! ji, a_i > zeps; zdh0 < 0 
     388               ! ji, a_i > epsi10; zdh0 < 0 
    465389               zdh0 = MIN(-zdh0,hi_max(klbnd)) 
    466390 
    … …  
    483407                  v_i(zji,zjj,klbnd)  = a_i(zji,zjj,klbnd)*ht_i(zji,zjj,klbnd) 
    484408               ENDIF     ! zetamax > 0 
    485                ! ji, a_i > zeps 
     409               ! ji, a_i > epsi10 
    486410 
    487411            ELSE ! if ice accretion 
    488                ! ji, a_i > zeps; zdh0 > 0 
     412               ! ji, a_i > epsi10; zdh0 > 0 
    489413               IF ( ntyp .EQ. 1 ) zhbnew(zji,zjj,klbnd-1) = MIN(zdh0,hi_max(klbnd))  
    490414               ! zhbnew was 0, and is shifted to the right to account for thin ice 
    … …  
    495419            ENDIF ! zdh0  
    496420 
    497             ! a_i > zeps 
    498          ENDIF ! a_i > zeps 
     421            ! a_i > epsi10 
     422         ENDIF ! a_i > epsi10 
    499423 
    500424      END DO ! ji 
    … …  
    571495         zjj = nind_j(ji) 
    572496         IF ( ( zhimin .GT. 0.0 ) .AND. &  
    573             ( ( a_i(zji,zjj,1) .GT. zeps ) .AND. ( ht_i(zji,zjj,1) .LT. zhimin ) ) & 
     497            ( ( a_i(zji,zjj,1) .GT. epsi10 ) .AND. ( ht_i(zji,zjj,1) .LT. zhimin ) ) & 
    574498            ) THEN 
    575499            a_i(zji,zjj,1)  = a_i(zji,zjj,1) * ht_i(zji,zjj,1) / zhimin  
    … …  
    602526 
    603527   END SUBROUTINE lim_itd_th_rem 
    604    ! 
    605  
    606    SUBROUTINE lim_itd_fitline(num_cat, HbL, Hbr, hice, g0, g1, hL, hR, zremap_flag ) 
    607  
     528 
     529 
     530   SUBROUTINE lim_itd_fitline( num_cat, HbL, Hbr, hice,   & 
     531      &                        g0, g1, hL, hR, zremap_flag ) 
    608532      !!------------------------------------------------------------------ 
    609533      !!                ***  ROUTINE lim_itd_fitline *** 
    610       !! ** Purpose : 
    611       !! fit g(h) with a line using area, volume constraints 
    612534      !! 
    613       !! ** Method  : 
    614       !! Fit g(h) with a line, satisfying area and volume constraints. 
    615       !! To reduce roundoff errors caused by large values of g0 and g1, 
    616       !! we actually compute g(eta), where eta = h - hL, and hL is the 
    617       !! left boundary. 
     535      !! ** Purpose :   fit g(h) with a line using area, volume constraints 
    618536      !! 
    619       !! ** Arguments : 
    620       !! 
    621       !! ** Inputs / Ouputs : (global commons) 
    622       !! 
    623       !! ** External :  
    624       !! 
    625       !! ** References : 
    626       !! 
    627       !! ** History : 
    628       !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 
    629       !!          (01-2006) Martin Vancoppenolle  
    630       !! 
    631       !!------------------------------------------------------------------ 
    632       !! * Arguments 
    633  
    634       INTEGER, INTENT(in) :: num_cat      ! category index 
    635  
    636       REAL(wp), DIMENSION(jpi,jpj), INTENT(IN)   ::   &  !: 
    637          HbL, HbR        ! left and right category boundaries 
    638  
    639       REAL(wp), DIMENSION(jpi,jpj), INTENT(IN)   ::   &  !: 
    640          hice            ! ice thickness 
    641  
    642       REAL(wp), DIMENSION(jpi,jpj), INTENT(OUT)  ::   &  !: 
    643          g0, g1      , & ! coefficients in linear equation for g(eta) 
    644          hL          , & ! min value of range over which g(h) > 0 
    645          hR              ! max value of range over which g(h) > 0 
    646  
    647       LOGICAL, DIMENSION(jpi,jpj), INTENT(IN)    ::   &  !: 
    648          zremap_flag 
    649  
    650       INTEGER :: &               
    651          ji,jj           ! horizontal indices 
    652  
    653       REAL(wp) :: &            
    654          zh13        , & ! HbL + 1/3 * (HbR - HbL) 
    655          zh23        , & ! HbL + 2/3 * (HbR - HbL) 
    656          zdhr        , & ! 1 / (hR - hL) 
    657          zwk1, zwk2  , & ! temporary variables 
    658          zacrith         ! critical minimum concentration in an ice category 
    659  
    660       REAL(wp)  ::           &  ! constant values 
    661          zeps      =  1.0e-10 
    662  
     537      !! ** Method  :   Fit g(h) with a line, satisfying area and volume constraints. 
     538      !!              To reduce roundoff errors caused by large values of g0 and g1, 
     539      !!              we actually compute g(eta), where eta = h - hL, and hL is the 
     540      !!              left boundary. 
     541      !!------------------------------------------------------------------ 
     542      INTEGER                     , INTENT(in   ) ::   num_cat      ! category index 
     543      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   HbL, HbR     ! left and right category boundaries 
     544      REAL(wp), DIMENSION(jpi,jpj), INTENT(in   ) ::   hice         ! ice thickness 
     545      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   g0, g1       ! coefficients in linear equation for g(eta) 
     546      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   hL           ! min value of range over which g(h) > 0 
     547      REAL(wp), DIMENSION(jpi,jpj), INTENT(  out) ::   hR           ! max value of range over which g(h) > 0 
     548      LOGICAL , DIMENSION(jpi,jpj), INTENT(in   ) ::   zremap_flag  ! 
     549      ! 
     550      INTEGER ::   ji,jj           ! horizontal indices 
     551      REAL(wp) ::   zh13         ! HbL + 1/3 * (HbR - HbL) 
     552      REAL(wp) ::   zh23         ! HbL + 2/3 * (HbR - HbL) 
     553      REAL(wp) ::   zdhr         ! 1 / (hR - hL) 
     554      REAL(wp) ::   zwk1, zwk2   ! temporary variables 
     555      REAL(wp) ::   zacrith      ! critical minimum concentration in an ice category 
     556      !!------------------------------------------------------------------ 
     557      ! 
    663558      zacrith       = 1.0e-6 
    664       !!-- End of declarations 
    665       !!---------------------------------------------------------------------------------------------- 
    666  
     559      ! 
    667560      DO jj = 1, jpj 
    668561         DO ji = 1, jpi 
    669  
    670             IF ( zremap_flag(ji,jj) .AND. a_i(ji,jj,num_cat) .gt. zacrith & 
    671                .AND. hice(ji,jj) .GT. 0.0 ) THEN 
     562            ! 
     563            IF( zremap_flag(ji,jj) .AND. a_i(ji,jj,num_cat) > zacrith  & 
     564               &                   .AND. hice(ji,jj)        > 0._wp    ) THEN 
    672565 
    673566               ! Initialize hL and hR 
    … …  
    681574               zh23 = 1.0/3.0 * (hL(ji,jj) + 2.0*hR(ji,jj)) 
    682575 
    683                IF (hice(ji,jj) < zh13) THEN 
    684                   hR(ji,jj) = 3.0*hice(ji,jj) - 2.0*hL(ji,jj) 
    685                ELSEIF (hice(ji,jj) > zh23) THEN 
    686                   hL(ji,jj) = 3.0*hice(ji,jj) - 2.0*hR(ji,jj) 
     576               IF    ( hice(ji,jj) < zh13 ) THEN   ;   hR(ji,jj) = 3._wp * hice(ji,jj) - 2._wp * hL(ji,jj) 
     577               ELSEIF( hice(ji,jj) > zh23 ) THEN   ;   hL(ji,jj) = 3._wp * hice(ji,jj) - 2._wp * hR(ji,jj) 
    687578               ENDIF 
    688579 
    689580               ! Compute coefficients of g(eta) = g0 + g1*eta 
    690581 
    691                zdhr = 1.0 / (hR(ji,jj) - hL(ji,jj)) 
    692                zwk1 = 6.0 * a_i(ji,jj,num_cat) * zdhr 
    693                zwk2 = (hice(ji,jj) - hL(ji,jj)) * zdhr 
    694                g0(ji,jj) = zwk1 * (2.0/3.0 - zwk2) 
    695                g1(ji,jj) = 2.0*zdhr * zwk1 * (zwk2 - 0.5) 
    696  
    697             ELSE                   ! remap_flag = .false. or a_i < zeps  
    698  
    699                hL(ji,jj) = 0.0 
    700                hR(ji,jj) = 0.0 
    701                g0(ji,jj) = 0.0 
    702                g1(ji,jj) = 0.0 
    703  
    704             ENDIF                  ! a_i > zeps 
    705  
    706          END DO !ji 
    707       END DO ! jj 
    708  
     582               zdhr = 1._wp / (hR(ji,jj) - hL(ji,jj)) 
     583               zwk1 = 6._wp * a_i(ji,jj,num_cat) * zdhr 
     584               zwk2 = ( hice(ji,jj) - hL(ji,jj) ) * zdhr 
     585               g0(ji,jj) = zwk1 * ( 2._wp/3._wp - zwk2 ) 
     586               g1(ji,jj) = 2._wp * zdhr * zwk1 * (zwk2 - 0.5) 
     587               ! 
     588            ELSE                   ! remap_flag = .false. or a_i < epsi10  
     589               hL(ji,jj) = 0._wp 
     590               hR(ji,jj) = 0._wp 
     591               g0(ji,jj) = 0._wp 
     592               g1(ji,jj) = 0._wp 
     593            ENDIF                  ! a_i > epsi10 
     594            ! 
     595         END DO 
     596      END DO 
     597      ! 
    709598   END SUBROUTINE lim_itd_fitline 
    710    ! 
    711  
    712    SUBROUTINE lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 
     599 
     600 
     601   SUBROUTINE lim_itd_shiftice( klbnd, kubnd, zdonor, zdaice, zdvice ) 
    713602      !!------------------------------------------------------------------ 
    714603      !!                ***  ROUTINE lim_itd_shiftice *** 
    715       !! ** Purpose : shift ice across category boundaries, conserving everything 
     604      !! 
     605      !! ** Purpose :   shift ice across category boundaries, conserving everything 
    716606      !!              ( area, volume, energy, age*vol, and mass of salt ) 
    717607      !! 
    718608      !! ** Method  : 
    719       !! 
    720       !! ** Arguments : 
    721       !! 
    722       !! ** Inputs / Ouputs : (global commons) 
    723       !! 
    724       !! ** External :  
    725       !! 
    726       !! ** References : 
    727       !! 
    728       !! ** History : 
    729       !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 
    730       !!          (01-2006) Martin Vancoppenolle  
    731       !! 
    732       !!------------------------------------------------------------------ 
    733       !! * Arguments 
    734  
    735       INTEGER , INTENT (IN) ::  & 
    736          klbnd ,  &  ! Start thickness category index point 
    737          kubnd       ! End point on which the  the computation is applied 
    738  
    739       INTEGER , DIMENSION(jpi,jpj,jpl-1), INTENT(IN) :: &  
    740          zdonor             ! donor category index 
    741  
    742       REAL(wp), DIMENSION(jpi,jpj,jpl-1), INTENT(INOUT) :: &  
    743          zdaice     ,  &   ! ice area transferred across boundary 
    744          zdvice            ! ice volume transferred across boundary 
    745  
    746       INTEGER :: & 
    747          ji,jj,jl,      &  ! horizontal indices, thickness category index 
    748          jl2,           &  ! receiver category 
    749          jl1,           &  ! donor category 
    750          jk,            &  ! ice layer index 
    751          zji, zjj          ! indices when changing from 2D-1D is done 
    752  
    753       REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 
    754          zaTsfn 
    755  
    756       REAL(wp), DIMENSION(jpi,jpj) :: & 
    757          zworka            ! temporary array used here 
    758  
    759       REAL(wp) :: &           
    760          zdvsnow     ,  &  ! snow volume transferred 
    761          zdesnow     ,  &  ! snow energy transferred 
    762          zdeice      ,  &  ! ice energy transferred 
    763          zdsm_vice      ,  &  ! ice salinity times volume transferred 
    764          zdo_aice      ,  &  ! ice age times volume transferred 
    765          zdaTsf      ,  &  ! aicen*Tsfcn transferred 
    766          zindsn      ,  &  ! snow or not 
    767          zindb             ! ice or not 
    768  
    769       INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) :: & 
    770          nind_i      ,  &  ! compressed indices for i/j directions 
    771          nind_j 
    772  
    773       INTEGER :: & 
    774          nbrem             ! number of cells with ice to transfer 
    775  
    776       LOGICAL :: & 
    777          zdaice_negative       , & ! true if daice < -puny 
    778          zdvice_negative       , & ! true if dvice < -puny 
    779          zdaice_greater_aicen  , & ! true if daice > aicen 
    780          zdvice_greater_vicen      ! true if dvice > vicen 
    781  
    782       REAL(wp)  ::           &  ! constant values 
    783          zeps      =  1.0e-10 
    784  
    785       !!-- End of declarations 
     609      !!------------------------------------------------------------------ 
     610      INTEGER , INTENT(in   ) ::   klbnd   ! Start thickness category index point 
     611      INTEGER , INTENT(in   ) ::   kubnd   ! End point on which the  the computation is applied 
     612 
     613      INTEGER , DIMENSION(jpi,jpj,jpl-1), INTENT(in   ) ::   zdonor   ! donor category index 
     614 
     615      REAL(wp), DIMENSION(jpi,jpj,jpl-1), INTENT(inout) ::   zdaice   ! ice area transferred across boundary 
     616      REAL(wp), DIMENSION(jpi,jpj,jpl-1), INTENT(inout) ::   zdvice   ! ice volume transferred across boundary 
     617 
     618      INTEGER ::   ji, jj, jl, jl2, jl1, jk   ! dummy loop indices 
     619      INTEGER ::   zji, zjj          ! indices when changing from 2D-1D is done 
     620 
     621      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zaTsfn 
     622 
     623      REAL(wp), DIMENSION(jpi,jpj) ::   zworka            ! temporary array used here 
     624 
     625      REAL(wp) ::   zdvsnow, zdesnow   ! snow volume and energy transferred 
     626      REAL(wp) ::   zdeice             ! ice energy transferred 
     627      REAL(wp) ::   zdsm_vice          ! ice salinity times volume transferred 
     628      REAL(wp) ::   zdo_aice           ! ice age times volume transferred 
     629      REAL(wp) ::   zdaTsf             ! aicen*Tsfcn transferred 
     630      REAL(wp) ::   zindsn             ! snow or not 
     631      REAL(wp) ::   zindb              ! ice or not 
     632 
     633      INTEGER, DIMENSION(1:(jpi+1)*(jpj+1)) ::   nind_i, nind_j   ! compressed indices for i/j directions 
     634 
     635      INTEGER ::   nbrem             ! number of cells with ice to transfer 
     636 
     637      LOGICAL ::   zdaice_negative         ! true if daice < -puny 
     638      LOGICAL ::   zdvice_negative         ! true if dvice < -puny 
     639      LOGICAL ::   zdaice_greater_aicen    ! true if daice > aicen 
     640      LOGICAL ::   zdvice_greater_vicen    ! true if dvice > vicen 
     641      !!------------------------------------------------------------------ 
    786642 
    787643      !---------------------------------------------------------------------------------------------- 
    … …  
    790646 
    791647      DO jl = klbnd, kubnd 
    792          DO jj = 1, jpj 
    793             DO ji = 1, jpi 
    794                zaTsfn(ji,jj,jl) = a_i(ji,jj,jl)*t_su(ji,jj,jl) 
    795             END DO ! ji 
    796          END DO ! jj 
    797       END DO ! jl 
     648         zaTsfn(:,:,jl) = a_i(:,:,jl)*t_su(:,:,jl) 
     649      END DO 
    798650 
    799651      !---------------------------------------------------------------------------------------------- 
    … …  
    821673 
    822674                  IF (zdaice(ji,jj,jl) .LT. 0.0) THEN 
    823                      IF (zdaice(ji,jj,jl) .GT. -zeps) THEN 
     675                     IF (zdaice(ji,jj,jl) .GT. -epsi10) THEN 
    824676                        IF ( ( jl1.EQ.jl   .AND. ht_i(ji,jj,jl1) .GT. hi_max(jl) )           & 
    825677                           .OR.                                      & 
    … …  
    838690 
    839691                  IF (zdvice(ji,jj,jl) .LT. 0.0) THEN 
    840                      IF (zdvice(ji,jj,jl) .GT. -zeps ) THEN 
     692                     IF (zdvice(ji,jj,jl) .GT. -epsi10 ) THEN 
    841693                        IF ( ( jl1.EQ.jl .AND. ht_i(ji,jj,jl1).GT.hi_max(jl) )     & 
    842694                           .OR.                                     & 
    … …  
    855707 
    856708                  ! If daice is close to aicen, set daice = aicen. 
    857                   IF (zdaice(ji,jj,jl) .GT. a_i(ji,jj,jl1) - zeps ) THEN 
    858                      IF (zdaice(ji,jj,jl) .LT. a_i(ji,jj,jl1)+zeps) THEN 
     709                  IF (zdaice(ji,jj,jl) .GT. a_i(ji,jj,jl1) - epsi10 ) THEN 
     710                     IF (zdaice(ji,jj,jl) .LT. a_i(ji,jj,jl1)+epsi10) THEN 
    859711                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    860712                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    … …  
    864716                  ENDIF 
    865717 
    866                   IF (zdvice(ji,jj,jl) .GT. v_i(ji,jj,jl1)-zeps) THEN 
    867                      IF (zdvice(ji,jj,jl) .LT. v_i(ji,jj,jl1)+zeps) THEN 
     718                  IF (zdvice(ji,jj,jl) .GT. v_i(ji,jj,jl1)-epsi10) THEN 
     719                     IF (zdvice(ji,jj,jl) .LT. v_i(ji,jj,jl1)+epsi10) THEN 
    868720                        zdaice(ji,jj,jl) = a_i(ji,jj,jl1) 
    869721                        zdvice(ji,jj,jl) = v_i(ji,jj,jl1)  
    … …  
    900752 
    901753            jl1 = zdonor(zji,zjj,jl) 
    902             zindb             = MAX( 0.0 , SIGN( 1.0 , v_i(zji,zjj,jl1) - zeps ) ) 
    903             zworka(zji,zjj)   = zdvice(zji,zjj,jl) / MAX(v_i(zji,zjj,jl1),zeps) * zindb 
    904             IF (jl1 .eq. jl) THEN 
    905                jl2 = jl1+1 
    906             ELSE                ! n1 = n+1 
    907                jl2 = jl  
     754            zindb             = MAX( 0.0 , SIGN( 1.0 , v_i(zji,zjj,jl1) - epsi10 ) ) 
     755            zworka(zji,zjj)   = zdvice(zji,zjj,jl) / MAX(v_i(zji,zjj,jl1),epsi10) * zindb 
     756            IF( jl1 == jl) THEN   ;   jl2 = jl1+1 
     757            ELSE                    ;   jl2 = jl  
    908758            ENDIF 
    909759 
    … …  
    996846         DO jj = 1, jpj 
    997847            DO ji = 1, jpi  
    998                IF ( a_i(ji,jj,jl) .GT. zeps ) THEN  
    999                   ht_i(ji,jj,jl)  =  v_i(ji,jj,jl) / a_i(ji,jj,jl)  
     848               IF ( a_i(ji,jj,jl) > epsi10 ) THEN  
     849                  ht_i(ji,jj,jl)  =  v_i   (ji,jj,jl) / a_i(ji,jj,jl)  
    1000850                  t_su(ji,jj,jl)  =  zaTsfn(ji,jj,jl) / a_i(ji,jj,jl)  
    1001851                  zindsn          =  1.0 - MAX(0.0,SIGN(1.0,-v_s(ji,jj,jl))) !0 if no ice and 1 if yes 
    1002852               ELSE 
    1003                   ht_i(ji,jj,jl)  = 0.0 
     853                  ht_i(ji,jj,jl)  = 0._wp 
    1004854                  t_su(ji,jj,jl)  = rtt 
    1005855               ENDIF 
    … …  
    1007857         END DO                 ! jj 
    1008858      END DO                    ! jl 
    1009  
     859      ! 
    1010860   END SUBROUTINE lim_itd_shiftice 
    1011    ! 
    1012  
    1013    SUBROUTINE lim_itd_th_reb(klbnd, kubnd, ntyp) 
     861    
     862 
     863   SUBROUTINE lim_itd_th_reb( klbnd, kubnd, ntyp ) 
    1014864      !!------------------------------------------------------------------ 
    1015865      !!                ***  ROUTINE lim_itd_th_reb *** 
     866      !! 
    1016867      !! ** Purpose : rebin - rebins thicknesses into defined categories 
    1017868      !! 
    1018869      !! ** Method  : 
    1019       !! 
    1020       !! ** Arguments : 
    1021       !! 
    1022       !! ** Inputs / Ouputs : (global commons) 
    1023       !! 
    1024       !! ** External :  
    1025       !! 
    1026       !! ** References : 
    1027       !! 
    1028       !! ** History : (2005) Translation from CICE 
    1029       !!              (2006) Adaptation to include salt, age and types 
    1030       !!              (2007) Mass conservation checked 
    1031       !! 
    1032       !! authors: William H. Lipscomb, LANL, Elizabeth C. Hunke, LANL 
    1033       !!          (01-2006) Martin Vancoppenolle (adaptation) 
    1034       !! 
    1035       !!------------------------------------------------------------------ 
    1036       !! * Arguments 
    1037       INTEGER , INTENT (in) ::  & 
    1038          klbnd ,  &  ! Start thickness category index point 
    1039          kubnd ,  &  ! End point on which the  the computation is applied 
    1040          ntyp        ! number of the ice type involved in the rebinning process 
    1041  
    1042       INTEGER :: & 
    1043          ji,jj,          &  ! horizontal indices 
    1044          jl                 ! category index 
    1045  
    1046       INTEGER ::   &  !: 
    1047          zshiftflag          ! = .true. if ice must be shifted 
    1048  
    1049       INTEGER, DIMENSION(jpi,jpj,jpl) :: & 
    1050          zdonor             ! donor category index 
    1051  
    1052       REAL(wp), DIMENSION(jpi, jpj, jpl) :: & 
    1053          zdaice         , & ! ice area transferred 
    1054          zdvice             ! ice volume transferred 
    1055  
    1056       REAL(wp)  ::           &  ! constant values 
    1057          zeps      =  1.0e-10, & 
    1058          epsi10    =  1.0e-10 
    1059  
    1060       REAL (wp), DIMENSION(jpi,jpj) :: &  !  
    1061          vt_i_init, vt_i_final,   &  !  ice volume summed over categories 
    1062          vt_s_init, vt_s_final       !  snow volume summed over categories 
    1063  
     870      !!------------------------------------------------------------------ 
     871      INTEGER , INTENT (in) ::   klbnd   ! Start thickness category index point 
     872      INTEGER , INTENT (in) ::   kubnd   ! End point on which the  the computation is applied 
     873      INTEGER , INTENT (in) ::   ntyp    ! number of the ice type involved in the rebinning process 
     874      ! 
     875      INTEGER ::   ji,jj, jl   ! dummy loop indices 
     876      INTEGER ::   zshiftflag          ! = .true. if ice must be shifted 
    1064877      CHARACTER (len = 15) :: fieldid 
    1065878 
    1066       !!-- End of declarations 
    1067       !------------------------------------------------------------------------------ 
    1068  
    1069       !     ! conservation check 
    1070       IF ( con_i ) THEN 
     879      INTEGER , DIMENSION(jpi,jpj,jpl) ::   zdonor           ! donor category index 
     880      REAL(wp), DIMENSION(jpi,jpj,jpl) ::   zdaice, zdvice   ! ice area and volume transferred 
     881 
     882      REAL (wp), DIMENSION(jpi,jpj) ::   vt_i_init, vt_i_final   ! ice volume summed over categories 
     883      REAL (wp), DIMENSION(jpi,jpj) ::   vt_s_init, vt_s_final   ! snow volume summed over categories 
     884      !!------------------------------------------------------------------ 
     885      !      
     886      IF( con_i ) THEN                 ! conservation check 
    1071887         CALL lim_column_sum (jpl,   v_i, vt_i_init) 
    1072888         CALL lim_column_sum (jpl,   v_s, vt_s_init) 
    … …  
    1080896         DO jj = 1, jpj 
    1081897            DO ji = 1, jpi  
    1082                IF (a_i(ji,jj,jl) .GT. zeps) THEN  
     898               IF( a_i(ji,jj,jl) > epsi10 ) THEN  
    1083899                  ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    1084900               ELSE 
    1085                   ht_i(ji,jj,jl) = 0.0 
     901                  ht_i(ji,jj,jl) = 0._wp 
    1086902               ENDIF 
    1087             END DO                 ! i 
    1088          END DO                 ! j 
    1089       END DO                    ! n 
     903            END DO 
     904         END DO 
     905      END DO 
    1090906 
    1091907      !------------------------------------------------------------------------------ 
    … …  
    1094910      DO jj = 1, jpj  
    1095911         DO ji = 1, jpi  
    1096  
    1097             IF (a_i(ji,jj,klbnd) > zeps) THEN 
    1098                IF (ht_i(ji,jj,klbnd) .LE. hi_max_typ(0,ntyp) .AND. hi_max_typ(0,ntyp) .GT. 0.0 ) THEN 
     912            IF( a_i(ji,jj,klbnd) > epsi10 ) THEN 
     913               IF( ht_i(ji,jj,klbnd) <= hi_max_typ(0,ntyp) .AND. hi_max_typ(0,ntyp) > 0._wp ) THEN 
    1099914                  a_i(ji,jj,klbnd)  = v_i(ji,jj,klbnd) / hi_max_typ(0,ntyp)  
    1100915                  ht_i(ji,jj,klbnd) = hi_max_typ(0,ntyp) 
    1101916               ENDIF 
    1102917            ENDIF 
    1103          END DO                    ! i 
    1104       END DO                    ! j 
     918         END DO 
     919      END DO 
    1105920 
    1106921      !------------------------------------------------------------------------------ 
    … …  
    1111926      ! Initialize shift arrays 
    1112927      !------------------------- 
    1113  
    1114928      DO jl = klbnd, kubnd 
    1115          DO jj = 1, jpj  
    1116             DO ji = 1, jpi 
    1117                zdonor(ji,jj,jl) = 0 
    1118                zdaice(ji,jj,jl) = 0.0 
    1119                zdvice(ji,jj,jl) = 0.0 
    1120             END DO 
    1121          END DO 
     929         zdonor(:,:,jl) = 0 
     930         zdaice(:,:,jl) = 0._wp 
     931         zdvice(:,:,jl) = 0._wp 
    1122932      END DO 
    1123933 
    … …  
    1135945         DO jj = 1, jpj  
    1136946            DO ji = 1, jpi  
    1137                IF (a_i(ji,jj,jl) .GT. zeps .AND. ht_i(ji,jj,jl) .GT. hi_max(jl) ) THEN  
     947               IF( a_i(ji,jj,jl) > epsi10 .AND. ht_i(ji,jj,jl) > hi_max(jl) ) THEN  
    1138948                  zshiftflag        = 1 
    1139949                  zdonor(ji,jj,jl)  = jl  
    … …  
    1143953            END DO                 ! ji 
    1144954         END DO                 ! jj 
    1145          IF( lk_mpp ) CALL mpp_max(zshiftflag) 
    1146  
    1147          IF ( zshiftflag == 1 ) THEN 
    1148  
    1149             !------------------------------ 
    1150             ! Shift ice between categories 
    1151             !------------------------------ 
    1152             CALL lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 
    1153  
    1154             !------------------------ 
     955         IF(lk_mpp)   CALL mpp_max( zshiftflag ) 
     956 
     957         IF( zshiftflag == 1 ) THEN            ! Shift ice between categories 
     958            CALL lim_itd_shiftice( klbnd, kubnd, zdonor, zdaice, zdvice ) 
    1155959            ! Reset shift parameters 
    1156             !------------------------ 
    1157             DO jj = 1, jpj 
    1158                DO ji = 1, jpi 
    1159                   zdonor(ji,jj,jl) = 0 
    1160                   zdaice(ji,jj,jl) = 0.0 
    1161                   zdvice(ji,jj,jl) = 0.0 
    1162                END DO 
    1163             END DO 
    1164  
    1165          ENDIF                  ! zshiftflag 
    1166  
     960            zdonor(:,:,jl) = 0 
     961            zdaice(:,:,jl) = 0._wp 
     962            zdvice(:,:,jl) = 0._wp 
     963         ENDIF 
     964         ! 
    1167965      END DO                    ! jl 
    1168966 
    … …  
    1180978         DO jj = 1, jpj 
    1181979            DO ji = 1, jpi 
    1182                IF (a_i(ji,jj,jl+1) .GT. zeps .AND. & 
    1183                   ht_i(ji,jj,jl+1) .LE. hi_max(jl)) THEN 
    1184  
     980               IF( a_i(ji,jj,jl+1) >  epsi10 .AND.  & 
     981                  ht_i(ji,jj,jl+1) <= hi_max(jl) ) THEN 
     982                  ! 
    1185983                  zshiftflag = 1 
    1186984                  zdonor(ji,jj,jl) = jl + 1 
    … …  
    1191989         END DO                 ! jj 
    1192990 
    1193          IF(lk_mpp) CALL mpp_max(zshiftflag) 
    1194          IF (zshiftflag==1) THEN 
    1195  
    1196             !------------------------------ 
    1197             ! Shift ice between categories 
    1198             !------------------------------ 
    1199             CALL lim_itd_shiftice (klbnd, kubnd, zdonor, zdaice, zdvice) 
    1200  
    1201             !------------------------ 
     991         IF(lk_mpp)   CALL mpp_max( zshiftflag ) 
     992          
     993         IF( zshiftflag == 1 ) THEN            ! Shift ice between categories 
     994            CALL lim_itd_shiftice( klbnd, kubnd, zdonor, zdaice, zdvice ) 
    1202995            ! Reset shift parameters 
    1203             !------------------------ 
    1204             DO jj = 1, jpj  
    1205                DO ji = 1, jpi  
    1206                   zdonor(ji,jj,jl)  = 0 
    1207                   zdaice(ji,jj,jl)  = 0.0 
    1208                   zdvice(ji,jj,jl)  = 0.0 
    1209                END DO 
    1210             END DO 
    1211  
    1212          ENDIF                  ! zshiftflag 
     996            zdonor(:,:,jl) = 0 
     997            zdaice(:,:,jl) = 0._wp 
     998            zdvice(:,:,jl) = 0._wp 
     999         ENDIF 
    12131000 
    12141001      END DO                    ! jl 
    … …  
    12181005      !------------------------------------------------------------------------------ 
    12191006 
    1220       IF ( con_i ) THEN 
     1007      IF( con_i ) THEN 
    12211008         CALL lim_column_sum (jpl,   v_i, vt_i_final) 
    12221009         fieldid = ' v_i : limitd_reb ' 
    … …  
    12271014         CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid)  
    12281015      ENDIF 
    1229  
     1016      ! 
    12301017   END SUBROUTINE lim_itd_th_reb 
    12311018 
    12321019#else 
    1233    !!====================================================================== 
    1234    !!                       ***  MODULE limitd_th    *** 
    1235    !!                              no sea ice model 
    1236    !!====================================================================== 
     1020   !!---------------------------------------------------------------------- 
     1021   !!   Default option            Dummy module         NO LIM sea-ice model 
     1022   !!---------------------------------------------------------------------- 
    12371023CONTAINS 
    12381024   SUBROUTINE lim_itd_th           ! Empty routines 
    … …  
    12491035   END SUBROUTINE lim_itd_th_reb 
    12501036#endif 
     1037   !!====================================================================== 
    12511038END MODULE limitd_th 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limmsh.F90

    r2528 r2612  
    1616   USE dom_ice        ! sea-ice domain 
    1717   USE in_out_manager ! I/O manager 
    18    USE lbclnk         !  
     18   USE lbclnk         ! lateral boundary condition - MPP exchanges 
    1919 
    2020   IMPLICIT NONE 
    … …  
    2424 
    2525   !!---------------------------------------------------------------------- 
    26    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     26   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    2727   !! $Id$ 
    28    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     28   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    2929   !!---------------------------------------------------------------------- 
    30  
    3130CONTAINS 
    3231 
    … …  
    4544      !!---------------------------------------------------------------------  
    4645      INTEGER  ::   ji, jj   ! dummy loop indices 
    47       REAL(wp) ::   zusden   ! temporary scalar 
     46      REAL(wp) ::   zusden   ! local scalar 
    4847      !!--------------------------------------------------------------------- 
    4948 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limrhg.F90

    r2590 r2612  
    88   !!             -   !  2008-11  (M. Vancoppenolle, S. Bouillon, Y. Aksenov) add surface tilt in ice rheolohy  
    99   !!            3.3  !  2009-05  (G.Garric) addition of the lim2_evp cas 
     10   !!            4.0  !  2011-01  (A Porter)  dynamical allocation  
    1011   !!---------------------------------------------------------------------- 
    1112#if defined key_lim3 || (  defined key_lim2 && ! defined key_lim2_vp ) 
    … …  
    4344   REAL(wp) ::   rone    = 1._wp   ! constant values 
    4445       
    45    REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: & 
    46          zpresh        ,             & !: temporary array for ice strength 
    47          zpreshc       ,             & !: Ice strength on grid cell corners (zpreshc) 
    48          zfrld1, zfrld2,             & !: lead fraction on U/V points                                     
    49          zmass1, zmass2,             & !: ice/snow mass on U/V points                                     
    50          zcorl1, zcorl2,             & !: coriolis parameter on U/V points 
    51          za1ct, za2ct  ,             & !: temporary arrays 
    52          zc1           ,             & !: ice mass 
    53          zusw          ,             & !: temporary weight for the computation 
    54                                 !: of ice strength 
    55          u_oce1, v_oce1,             & !: ocean u/v component on U points                            
    56          u_oce2, v_oce2,             & !: ocean u/v component on V points 
    57          u_ice2,                     & !: ice u component on V point 
    58          v_ice1                        !: ice v component on U point 
    59  
    60    REAL(wp),ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zf1, zf2   ! arrays for internal stresses 
    61  
    62    REAL(wp),ALLOCATABLE, SAVE, DIMENSION(:,:) :: & 
    63          zdd, zdt,                   & ! Divergence and tension at centre of grid cells 
    64          zds,                        & ! Shear on northeast corner of grid cells 
    65          deltat,                     & ! Delta at centre of grid cells 
    66          deltac,                     & ! Delta on corners 
    67          zs1, zs2,                   & ! Diagonal stress tensor components zs1 and zs2  
    68          zs12                          ! Non-diagonal stress tensor component zs12 
    69  
    70    REAL(wp),ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zu_ice, zv_ice, zresr   ! Local error on velocity 
     46   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zpresh           ! temporary array for ice strength 
     47   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zpreshc          ! Ice strength on grid cell corners (zpreshc) 
     48   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zfrld1, zfrld2   ! lead fraction on U/V points                                     
     49   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zmass1, zmass2   ! ice/snow mass on U/V points                                     
     50   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zcorl1, zcorl2   ! coriolis parameter on U/V points 
     51   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   za1ct , za2ct    ! temporary arrays 
     52   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zc1              ! ice mass 
     53   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zusw             ! temporary weight for ice strength computation 
     54   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce1, v_oce1   ! ocean u/v component on U points                            
     55   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_oce2, v_oce2   ! ocean u/v component on V points 
     56   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   u_ice2, v_ice1   ! ice u/v component on V/U point 
     57   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zf1   , zf2      ! arrays for internal stresses 
     58 
     59   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zdd   , zdt      ! Divergence and tension at centre of grid cells 
     60   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zds              ! Shear on northeast corner of grid cells 
     61   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   deltat, deltac   ! Delta at centre and corners of grid cells 
     62   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zs1   , zs2      ! Diagonal stress tensor components zs1 and zs2  
     63   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zs12             ! Non-diagonal stress tensor component zs12 
     64   REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) ::   zu_ice, zv_ice, zresr   ! Local error on velocity 
    7165 
    7266   !! * Substitutions 
    7367#  include "vectopt_loop_substitute.h90" 
    7468   !!---------------------------------------------------------------------- 
    75    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     69   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    7670   !! $Id$ 
    7771   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    8377      !!                 ***  FUNCTION lim_rhg_alloc  *** 
    8478      !!------------------------------------------------------------------- 
    85       IMPLICIT none 
    86       INTEGER :: lim_rhg_alloc 
    87       INTEGER :: ierr(2) 
     79      INTEGER :: lim_rhg_alloc   ! return value 
     80      INTEGER :: ierr(2)         ! local integer 
    8881      !!------------------------------------------------------------------- 
    89  
     82      ! 
    9083      ierr(:) = 0 
    91  
    92       ALLOCATE(zpresh(jpi,jpj), zpreshc(jpi,jpj), & 
    93                zfrld1(jpi,jpj), zfrld2(jpi,jpj),  & 
    94                zmass1(jpi,jpj), zmass2(jpi,jpj),  & 
    95                zcorl1(jpi,jpj), zcorl2(jpi,jpj),  & 
    96                za1ct(jpi,jpj),  za2ct(jpi,jpj) ,  & 
    97                zc1(jpi,jpj)   , zusw(jpi,jpj)  ,  & 
    98                u_oce1(jpi,jpj), v_oce1(jpi,jpj),  & 
    99                u_oce2(jpi,jpj), v_oce2(jpi,jpj),  & 
    100                u_ice2(jpi,jpj), v_ice1(jpi,jpj), Stat=ierr(1)) 
    101  
    102       ALLOCATE(zf1(jpi,jpj),    zf2(jpi,jpj),               & 
    103                zdd(jpi,jpj),    zdt(jpi,jpj), zds(jpi,jpj), & 
    104                deltat(jpi,jpj), deltac(jpi,jpj),            & 
    105                zs1(jpi,jpj),    zs2(jpi,jpj), zs12(jpi,jpj),& 
    106                zu_ice(jpi,jpj), zv_ice(jpi,jpj),            & 
    107                zresr(jpi,jpj), Stat=ierr(2)) 
    108  
     84      ! 
     85      ALLOCATE( zpresh (jpi,jpj) , zfrld1(jpi,jpj), zmass1(jpi,jpj), zcorl1(jpi,jpj), za1ct(jpi,jpj) ,      & 
     86         &      zpreshc(jpi,jpj) , zfrld2(jpi,jpj), zmass2(jpi,jpj), zcorl2(jpi,jpj), za2ct(jpi,jpj) ,      & 
     87         &      zc1    (jpi,jpj) , u_oce1(jpi,jpj), u_oce2(jpi,jpj), u_ice2(jpi,jpj),                       & 
     88         &      zusw   (jpi,jpj) , v_oce1(jpi,jpj), v_oce2(jpi,jpj), v_ice1(jpi,jpj)                 ,  STAT=ierr(1) ) 
     89         ! 
     90      ALLOCATE( zf1(jpi,jpj) , deltat(jpi,jpj) , zu_ice(jpi,jpj) ,                     & 
     91         &      zf2(jpi,jpj) , deltac(jpi,jpj) , zv_ice(jpi,jpj) ,                     & 
     92         &      zdd(jpi,jpj) , zdt   (jpi,jpj) , zds   (jpi,jpj) ,                     & 
     93         &      zs1(jpi,jpj) , zs2   (jpi,jpj) , zs12  (jpi,jpj) , zresr(jpi,jpj), STAT=ierr(2) ) 
     94         ! 
    10995      lim_rhg_alloc = MAXVAL(ierr) 
    110  
     96      ! 
    11197   END FUNCTION lim_rhg_alloc 
    11298 
    … …  
    172158      REAL(wp) ::   za, zstms, zsang, zmask   ! local scalars 
    173159 
    174       REAL(wp) :: & 
    175          dtevp,                      & ! time step for subcycling 
    176          dtotel,                     & ! 
    177          ecc2,                       & ! square of yield ellipse eccenticity 
    178          z0,                         & ! temporary scalar 
    179          zr,                         & ! temporary scalar 
    180          zcca, zccb,                 & ! temporary scalars 
    181          zu_ice2,                    & !  
    182          zv_ice1,                    & ! 
    183          zddc, zdtc,                 & ! temporary array for delta on corners 
    184          zdst,                       & ! temporary array for delta on centre 
    185          zdsshx, zdsshy,             & ! term for the gradient of ocean surface 
    186          sigma1, sigma2                ! internal ice stress 
    187  
    188       REAL(wp) :: & 
    189          zresm            ,          & ! Maximal error on ice velocity 
    190          zindb            ,          & ! ice (1) or not (0)       
    191          zdummy                        ! dummy argument 
    192  
     160      REAL(wp) ::   dtevp              ! time step for subcycling 
     161      REAL(wp) ::   dtotel, ecc2       ! square of yield ellipse eccenticity 
     162      REAL(wp) ::   z0, zr, zcca, zccb ! temporary scalars 
     163      REAL(wp) ::   zu_ice2, zv_ice1   ! 
     164      REAL(wp) ::   zddc, zdtc, zdst   ! delta on corners and on centre 
     165      REAL(wp) ::   zdsshx, zdsshy     ! term for the gradient of ocean surface 
     166      REAL(wp) ::   sigma1, sigma2     ! internal ice stress 
     167 
     168      REAL(wp) ::   zresm         ! Maximal error on ice velocity 
     169      REAL(wp) ::   zindb         ! ice (1) or not (0)       
     170      REAL(wp) ::   zdummy        ! dummy argument 
    193171      !!------------------------------------------------------------------- 
    194172#if  defined key_lim2 && ! defined key_lim2_vp 
    … …  
    782760         ENDIF 
    783761      ENDIF 
    784  
     762      ! 
    785763   END SUBROUTINE lim_rhg 
    786764 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limrst.F90

    r2528 r2612  
    66   !! History:   -   ! 2005-04 (M. Vancoppenolle) Original code 
    77   !!           3.0  ! 2008-03 (C. Ethe) restart files in using IOM interface 
     8   !!           4.0  ! 2011-02 (G. Madec) dynamical allocation 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    3435 
    3536   !!---------------------------------------------------------------------- 
    36    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     37   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3738   !! $Id$ 
    3839   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    9091      !! ** purpose  :   output of sea-ice variable in a netcdf file 
    9192      !!---------------------------------------------------------------------- 
     93      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     94      USE wrk_nemo, ONLY:   z2d  => wrk_2d_1   ! 2D workspace 
     95      ! 
    9296      INTEGER, INTENT(in) ::   kt     ! number of iteration 
    9397      !! 
    … …  
    96100      CHARACTER(len=15) ::   znam 
    97101      CHARACTER(len=1)  ::   zchar, zchar1 
    98       REAL(wp), DIMENSION(jpi,jpj) :: z2d 
    99       !!---------------------------------------------------------------------- 
     102      !!---------------------------------------------------------------------- 
     103 
     104      IF( .NOT. wrk_use(2, 1) ) THEN 
     105         CALL ctl_stop( 'lim_rst_write : requested workspace arrays unavailable.' )   ;   RETURN 
     106      END IF 
    100107 
    101108      iter = kt + nn_fsbc - 1   ! ice restarts are written at kt == nitrst - nn_fsbc + 1 
    … …  
    287294      ENDIF 
    288295      ! 
     296      IF( .NOT. wrk_release(2, 1) ) THEN 
     297         CALL ctl_stop( 'lim_rst_write : failed to release workspace arrays.' ) 
     298      END IF 
     299      ! 
    289300   END SUBROUTINE lim_rst_write 
    290301 
    … …  
    296307      !! ** purpose  :   read of sea-ice variable restart in a netcdf file 
    297308      !!---------------------------------------------------------------------- 
     309      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     310      USE wrk_nemo, ONLY:   z2d  => wrk_2d_1   ! 2D workspace 
     311      ! 
    298312      INTEGER :: ji, jj, jk, jl, indx 
    299313      REAL(wp) ::   zfice, ziter 
    300314      REAL(wp) ::   zs_inf, z_slope_s, zsmax, zsmin, zalpha, zindb   ! local scalars used for the salinity profile 
    301315      REAL(wp), DIMENSION(nlay_i)  ::   zs_zero  
    302       REAL(wp), DIMENSION(jpi,jpj) ::   z2d 
    303316      CHARACTER(len=15) ::   znam 
    304317      CHARACTER(len=1)  ::   zchar, zchar1 
    … …  
    307320      !!---------------------------------------------------------------------- 
    308321 
     322      IF( .NOT. wrk_use(2, 1) ) THEN 
     323         CALL ctl_stop( 'lim_rst_read : requested workspace arrays unavailable.' )   ;   RETURN 
     324      END IF 
     325 
    309326      IF(lwp) THEN 
    310327         WRITE(numout,*) 
    311328         WRITE(numout,*) 'lim_rst_read : read ice NetCDF restart file' 
    312          WRITE(numout,*) '~~~~~~~~~~~~~~' 
     329         WRITE(numout,*) '~~~~~~~~~~~~~' 
    313330      ENDIF 
    314331 
    … …  
    554571      CALL iom_close( numrir ) 
    555572      ! 
     573      IF( .NOT. wrk_release(2, 1) ) THEN 
     574         CALL ctl_stop( 'lim_rst_read : failed to release workspace arrays.' ) 
     575      END IF 
     576      ! 
    556577   END SUBROUTINE lim_rst_read 
    557578 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limsbc.F90

    r2601 r2612  
    99   !!            3.3  ! 2010-05 (G. Madec) decrease ocean & ice reference salinities in the Baltic sea 
    1010   !!                 !                  + simplification of the ice-ocean stress calculation 
     11   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    1112   !!---------------------------------------------------------------------- 
    1213#if defined key_lim3 
    … …  
    1415   !!   'key_lim3'                                    LIM 3.0 sea-ice model 
    1516   !!---------------------------------------------------------------------- 
    16    !!   lim_sbc_flx  : updates mass, heat and salt fluxes at the ocean surface 
    17    !!   lim_sbc_tau  : update i- and j-stresses, and its modulus at the ocean surface 
     17   !!   lim_sbc_alloc : allocate the limsbc arrays 
     18   !!   lim_sbc_init  : initialisation 
     19   !!   lim_sbc_flx   : updates mass, heat and salt fluxes at the ocean surface 
     20   !!   lim_sbc_tau   : update i- and j-stresses, and its modulus at the ocean surface 
    1821   !!---------------------------------------------------------------------- 
    1922   USE par_oce          ! ocean parameters 
    … …  
    3336   PRIVATE 
    3437 
    35    PUBLIC   lim_sbc_flx   ! called by sbc_ice_lim 
    36    PUBLIC   lim_sbc_tau   ! called by sbc_ice_lim 
     38   PUBLIC   lim_sbc_init   ! called by ice_init 
     39   PUBLIC   lim_sbc_flx    ! called by sbc_ice_lim 
     40   PUBLIC   lim_sbc_tau    ! called by sbc_ice_lim 
    3741 
    3842   REAL(wp)  ::   r1_rdtice            ! = 1. / rdt_ice  
    … …  
    4852#  include "vectopt_loop_substitute.h90" 
    4953   !!---------------------------------------------------------------------- 
    50    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     54   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    5155   !! $Id$ 
    5256   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5357   !!---------------------------------------------------------------------- 
    5458CONTAINS 
     59 
     60   FUNCTION lim_sbc_alloc() 
     61      !!------------------------------------------------------------------- 
     62      !!             ***  ROUTINE lim_sbc_alloc *** 
     63      !!------------------------------------------------------------------- 
     64      INTEGER :: lim_sbc_alloc   ! return value 
     65      !!------------------------------------------------------------------- 
     66      ! 
     67      ALLOCATE( soce_0(jpi,jpj) , utau_oce(jpi,jpj) ,                       & 
     68         &      sice_0(jpi,jpj) , vtau_oce(jpi,jpj) , tmod_io(jpi,jpj), STAT=lim_sbc_alloc) 
     69         ! 
     70      IF( lk_mpp             )   CALL mpp_sum( lim_sbc_alloc ) 
     71      IF( lim_sbc_alloc /= 0 )   CALL ctl_warn('lim_sbc_alloc: failed to allocate arrays.') 
     72      ! 
     73   END FUNCTION lim_sbc_alloc 
     74 
    5575 
    5676   SUBROUTINE lim_sbc_flx( kt ) 
    … …  
    92112 
    93113      IF( .NOT.wrk_use(2, 1,2) .OR. .NOT.wrk_use(3, 4,5) ) THEN 
    94          CALL ctl_stop( 'lim_sbc_flx_2 : requested workspace arrays unavailable.' )   ;   RETURN 
     114         CALL ctl_stop( 'lim_sbc_flx : requested workspace arrays unavailable.' )   ;   RETURN 
    95115      ENDIF 
    96116      ! Set-up pointers to sub-arrays of 3d workspaces 
    97117      zalb  => wrk_3d_4(:,:,1:jpl) 
    98118      zalbp => wrk_3d_5(:,:,1:jpl) 
    99  
    100       IF( kt == nit000 ) THEN 
    101          IF(lwp) WRITE(numout,*) 
    102          IF(lwp) WRITE(numout,*) 'lim_sbc_flx : LIM 3.0 sea-ice - heat salt and mass ocean surface fluxes' 
    103          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 
    104          ! 
    105          r1_rdtice = 1. / rdt_ice 
    106          ! 
    107          ALLOCATE( soce_0(jpi,jpj) , utau_oce(jpi,jpj) ,                        & 
    108             &      sice_0(jpi,jpj) , vtau_oce(jpi,jpj) , tmod_io(jpi,jpj) , STAT=ierr ) 
    109          ! 
    110          IF( ierr /= 0 ) THEN 
    111             CALL ctl_stop( 'lim_sbc_flx: failed to allocate arrays.' )   ;   RETURN 
    112          END IF 
    113          ! 
    114          soce_0(:,:) = soce 
    115          sice_0(:,:) = sice 
    116          ! 
    117          IF( cp_cfg == "orca" ) THEN           ! decrease ocean & ice reference salinities in the Baltic sea  
    118             WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.   & 
    119                &   54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp         )  
    120                soce_0(:,:) = 4._wp 
    121                sice_0(:,:) = 2._wp 
    122             END WHERE 
    123          ENDIF 
    124          ! 
    125       ENDIF 
    126119 
    127120      !------------------------------------------! 
    … …  
    307300      ENDIF 
    308301      ! 
    309       IF(  .NOT. wrk_release(2, 1)  .OR.  .NOT. wrk_release(3, 4,5)  ) THEN 
    310          CALL ctl_stop( 'lim_sbc_flx_2 : failed to release workspace arrays.' ) 
     302      IF(  .NOT. wrk_release(2, 1,2)  .OR.  .NOT. wrk_release(3, 4,5)  ) THEN 
     303         CALL ctl_stop( 'lim_sbc_flx : failed to release workspace arrays.' ) 
    311304      END IF 
    312305      !  
    … …  
    345338      REAL(wp) ::   zat_u, zutau_ice, zu_t, zmodt   ! local scalar 
    346339      REAL(wp) ::   zat_v, zvtau_ice, zv_t          !   -      - 
    347      !!--------------------------------------------------------------------- 
    348  
    349       IF( kt == nit000 ) THEN 
    350          IF(lwp) WRITE(numout,*) 
    351          IF(lwp) WRITE(numout,*) 'lim_sbc_tau : LIM-3 sea-ice - surface ocean momentum fluxes' 
    352          IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ ' 
    353       ENDIF 
    354  
     340      !!--------------------------------------------------------------------- 
     341      ! 
    355342      IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN     !==  Ice time-step only  ==!   (i.e. surface module time-step) 
    356343!CDIR NOVERRCHK 
    … …  
    374361         ! 
    375362      ENDIF 
    376          ! 
    377          !                                     !==  every ocean time-step  ==! 
    378          ! 
     363      ! 
     364      !                                      !==  every ocean time-step  ==! 
     365      ! 
    379366      DO jj = 2, jpjm1                                !* update the stress WITHOUT a ice-ocean rotation angle 
    380367         DO ji = fs_2, fs_jpim1   ! Vect. Opt. 
    … …  
    396383   END SUBROUTINE lim_sbc_tau 
    397384 
     385 
     386   SUBROUTINE lim_sbc_init 
     387      !!------------------------------------------------------------------- 
     388      !!                  ***  ROUTINE lim_sbc_init  *** 
     389      !!              
     390      !! ** Purpose : Preparation of the file ice_evolu for the output of 
     391      !!      the temporal evolution of key variables 
     392      !! 
     393      !! ** input   : Namelist namicedia 
     394      !!------------------------------------------------------------------- 
     395      ! 
     396      IF(lwp) WRITE(numout,*) 
     397      IF(lwp) WRITE(numout,*) 'lim_sbc_init : LIM-3 sea-ice - surface boundary condition' 
     398      IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~   ' 
     399 
     400      !                                      ! allocate lim_sbc array 
     401      IF( lim_sbc_alloc() /= 0 )   CALL ctl_stop( 'STOP', 'lim_sbc_init : unable to allocate standard arrays' ) 
     402      ! 
     403      r1_rdtice = 1. / rdt_ice 
     404      ! 
     405      soce_0(:,:) = soce                     ! constant SSS and ice salinity used in levitating sea-ice case 
     406      sice_0(:,:) = sice 
     407      ! 
     408      IF( cp_cfg == "orca" ) THEN            ! decrease ocean & ice reference salinities in the Baltic sea  
     409         WHERE( 14._wp <= glamt(:,:) .AND. glamt(:,:) <= 32._wp .AND.   & 
     410            &   54._wp <= gphit(:,:) .AND. gphit(:,:) <= 66._wp         )  
     411            soce_0(:,:) = 4._wp 
     412            sice_0(:,:) = 2._wp 
     413         END WHERE 
     414      ENDIF 
     415      ! 
     416   END SUBROUTINE lim_sbc_init 
     417 
    398418#else 
    399419   !!---------------------------------------------------------------------- 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limtab.F90

    r2528 r2612  
    22   !!====================================================================== 
    33   !!                       ***  MODULE limtab   *** 
    4    !!             transform 1D (2D) array to a 2D (1D) table 
     4   !!   LIM : transform 1D (2D) array to a 2D (1D) table 
    55   !!====================================================================== 
    66#if defined key_lim3 
    … …  
    88   !!   'key_lim3'                                      LIM3 sea-ice model 
    99   !!---------------------------------------------------------------------- 
    10    !!   tab_2d_1d  : 2-D to 1-D 
    11    !!   tab_1d_2d  : 1-D to 2-D 
     10   !!   tab_2d_1d  : 2-D <==> 1-D 
     11   !!   tab_1d_2d  : 1-D <==> 2-D 
    1212   !!---------------------------------------------------------------------- 
    13    !! * Modules used 
    1413   USE par_kind 
    1514 
    … …  
    1716   PRIVATE 
    1817 
    19    !! * Routine accessibility 
    20    PUBLIC tab_2d_1d  ! called by lim_ther 
    21    PUBLIC tab_1d_2d  ! called by lim_ther 
     18   PUBLIC   tab_2d_1d   ! called by limthd 
     19   PUBLIC   tab_1d_2d   ! called by limthd 
    2220 
    2321   !!---------------------------------------------------------------------- 
    24    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     22   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2010) 
    2523   !! $Id$ 
    26    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     24   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    2725   !!---------------------------------------------------------------------- 
    2826CONTAINS 
    2927 
    30    SUBROUTINE tab_2d_1d ( ndim1d, tab1d, tab2d, ndim2d_x, ndim2d_y, tab_ind ) 
    31  
    32       INTEGER, INTENT(in) :: & 
    33          ndim1d, ndim2d_x, ndim2d_y 
    34  
    35       REAL(wp), DIMENSION (ndim2d_x, ndim2d_y), INTENT(in) ::  & 
    36          tab2d 
    37  
    38       INTEGER, DIMENSION ( ndim1d), INTENT ( in) :: & 
    39          tab_ind 
    40  
    41       REAL(wp), DIMENSION(ndim1d), INTENT ( out) ::  &  
    42          tab1d 
    43  
    44       INTEGER ::  & 
    45          jn , jid, jjd 
    46  
     28   SUBROUTINE tab_2d_1d( ndim1d, tab1d, tab2d, ndim2d_x, ndim2d_y, tab_ind ) 
     29      !!---------------------------------------------------------------------- 
     30      !!                  ***  ROUTINE tab_2d_1d  *** 
     31      !!---------------------------------------------------------------------- 
     32      INTEGER                               , INTENT(in   ) ::   ndim1d, ndim2d_x, ndim2d_y   ! 1d & 2D sizes 
     33      REAL(wp), DIMENSION(ndim2d_x,ndim2d_y), INTENT(in   ) ::   tab2d                        ! input 2D field 
     34      INTEGER , DIMENSION(ndim1d)           , INTENT(in   ) ::   tab_ind                      ! input index 
     35      REAL(wp), DIMENSION(ndim1d)           , INTENT(  out) ::   tab1d                        ! output 1D field 
     36      ! 
     37      INTEGER ::   jn , jid, jjd 
     38      !!---------------------------------------------------------------------- 
    4739      DO jn = 1, ndim1d 
    48          jid        = MOD( tab_ind(jn) - 1, ndim2d_x ) + 1 
    49          jjd        = ( tab_ind(jn) - 1 ) / ndim2d_x + 1 
     40         jid        = MOD( tab_ind(jn) - 1 , ndim2d_x ) + 1 
     41         jjd        =    ( tab_ind(jn) - 1 ) / ndim2d_x + 1 
    5042         tab1d( jn) = tab2d( jid, jjd) 
    5143      END DO 
    52  
    5344   END SUBROUTINE tab_2d_1d 
    5445 
    5546 
    56    SUBROUTINE tab_1d_2d ( ndim1d, tab2d, tab_ind, tab1d, ndim2d_x, ndim2d_y ) 
    57  
    58       INTEGER, INTENT ( in) :: & 
    59          ndim1d, ndim2d_x, ndim2d_y 
    60  
    61       INTEGER, DIMENSION (ndim1d) , INTENT (in) :: & 
    62          tab_ind 
    63  
    64       REAL(wp), DIMENSION(ndim1d), INTENT (in) ::  & 
    65          tab1d   
    66  
    67       REAL(wp), DIMENSION (ndim2d_x, ndim2d_y), INTENT ( out) :: & 
    68          tab2d 
    69  
    70       INTEGER :: & 
    71          jn, jid, jjd 
    72  
     47   SUBROUTINE tab_1d_2d( ndim1d, tab2d, tab_ind, tab1d, ndim2d_x, ndim2d_y ) 
     48      !!---------------------------------------------------------------------- 
     49      !!                  ***  ROUTINE tab_2d_1d  *** 
     50      !!---------------------------------------------------------------------- 
     51      INTEGER                               , INTENT(in   ) ::   ndim1d, ndim2d_x, ndim2d_y   ! 1d & 2D sizes 
     52      REAL(wp), DIMENSION(ndim1d)           , INTENT(in   ) ::   tab1d                        ! input 1D field 
     53      INTEGER , DIMENSION(ndim1d)           , INTENT(in   ) ::   tab_ind                      ! input index 
     54      REAL(wp), DIMENSION(ndim2d_x,ndim2d_y), INTENT(  out) ::   tab2d                        ! output 2D field 
     55      ! 
     56      INTEGER ::   jn , jid, jjd 
     57      !!---------------------------------------------------------------------- 
    7358      DO jn = 1, ndim1d 
    74          jid             = MOD( tab_ind(jn) - 1, ndim2d_x) + 1 
     59         jid             = MOD( tab_ind(jn) - 1 ,  ndim2d_x ) + 1 
    7560         jjd             =    ( tab_ind(jn) - 1 ) / ndim2d_x  + 1 
    7661         tab2d(jid, jjd) = tab1d( jn) 
    7762      END DO 
    78  
    7963   END SUBROUTINE tab_1d_2d 
    8064 
     65#else 
     66   !!---------------------------------------------------------------------- 
     67   !!   Default option        Dummy module             NO LIM sea-ice model 
     68   !!---------------------------------------------------------------------- 
    8169#endif 
     70   !!====================================================================== 
    8271END MODULE limtab 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd.F90

    r2528 r2612  
    1010   !!            3.2  ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in rdmsnif 
    1111   !!            3.3  ! 2010-11 (G. Madec) corrected snow melting heat (due to factor betas) 
     12   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    1213   !!---------------------------------------------------------------------- 
    1314#if defined key_lim3 
    … …  
    4647   REAL(wp) ::   epsi20 = 1e-20_wp   ! constant values 
    4748   REAL(wp) ::   epsi16 = 1e-16_wp   ! 
     49   REAL(wp) ::   epsi10 = 1e-10_wp   ! 
    4850   REAL(wp) ::   epsi06 = 1e-06_wp   ! 
    4951   REAL(wp) ::   epsi04 = 1e-04_wp   ! 
    … …  
    7981      !! ** References : H. Goosse et al. 1996, Bul. Soc. Roy. Sc. Liege, 65, 87-90 
    8082      !!--------------------------------------------------------------------- 
     83      USE wrk_nemo, ONLY:   wrk_use, wrk_release 
     84      USE wrk_nemo, ONLY:   zqlbsbq => wrk_2d_1   ! 2D workspace 
     85      ! 
    8186      INTEGER, INTENT(in) ::   kt    ! number of iteration 
    8287      !! 
    8388      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    8489      INTEGER  ::   nbpb             ! nb of icy pts for thermo. cal. 
    85       REAL(wp) ::   zfric_umin = 5e-03    ! lower bound for the friction velocity 
    86       REAL(wp) ::   zfric_umax = 2e-02    ! upper bound for the friction velocity 
    87       REAL(wp) ::   zinda, zindb, zthsnice, zfric_u    ! temporary scalar 
    88       REAL(wp) ::   zfntlat, zpareff   !    -         - 
    89       REAL(wp) ::   zeps, zareamin, zcoef 
    90       REAL(wp), DIMENSION(jpi,jpj) ::   zqlbsbq   ! link with lead energy budget qldif 
     90      REAL(wp) ::   zfric_umin = 5e-03_wp    ! lower bound for the friction velocity 
     91      REAL(wp) ::   zfric_umax = 2e-02_wp    ! upper bound for the friction velocity 
     92      REAL(wp) ::   zinda, zindb, zthsnice, zfric_u     ! local scalar 
     93      REAL(wp) ::   zfntlat, zpareff, zareamin, zcoef   !    -         - 
    9194      !!------------------------------------------------------------------- 
    92        
     95 
     96      IF( .NOT. wrk_use(2, 1) ) THEN 
     97         CALL ctl_stop( 'lim_thd : requested workspace arrays unavailable' )   ;   RETURN 
     98      END IF 
     99    
    93100      !------------------------------------------------------------------------------! 
    94101      ! 1) Initialization of diagnostic variables                                    ! 
    95102      !------------------------------------------------------------------------------! 
    96       zeps = 1.e-10 
    97103 
    98104      !-------------------- 
    … …  
    387393      !------------------------ 
    388394      ! Enthalpies are global variables we have to readjust the units 
    389       zcoef = 1.e0 / ( unit_fac * REAL(nlay_i) ) 
     395      zcoef = 1._wp / ( unit_fac * REAL( nlay_i ) ) 
    390396      DO jl = 1, jpl 
    391397         DO jk = 1, nlay_i 
    … …  
    399405      !------------------------ 
    400406      ! Enthalpies are global variables we have to readjust the units 
    401       zcoef = 1.e0 / ( unit_fac * REAL(nlay_s) ) 
     407      zcoef = 1._wp / ( unit_fac * REAL( nlay_s ) ) 
    402408      DO jl = 1, jpl 
    403409         DO jk = 1, nlay_s 
    … …  
    452458      ENDIF 
    453459      ! 
     460      IF( .NOT. wrk_release(2, 1) )   CALL ctl_stop( 'lim_thd : failed to release workspace arrays' ) 
     461      ! 
    454462   END SUBROUTINE lim_thd 
    455463 
    … …  
    468476      !! 
    469477      INTEGER  ::   ji,jk   ! loop indices 
    470       REAL(wp) ::   zeps    ! very small value (1.e-10) 
    471478      !!----------------------------------------------------------------------- 
    472       eti(:,:) = 0.e0 
    473       ets(:,:) = 0.e0 
    474       zeps     = 1.e-10 
    475  
     479      eti(:,:) = 0._wp 
     480      ets(:,:) = 0._wp 
     481      ! 
    476482      DO jk = 1, nlay_i                ! total q over all layers, ice [J.m-2] 
    477483         DO ji = kideb, kiut 
    … …  
    483489         ets(ji,jl) = ets(ji,jl) + q_s_b(ji,1) * ht_s_b(ji) / nlay_s 
    484490      END DO 
    485  
     491      ! 
    486492      IF(lwp) WRITE(numout,*) ' lim_thd_glohec ' 
    487493      IF(lwp) WRITE(numout,*) ' qt_i_in : ', eti(jiindex_1d,jl) / rdt_ice 
    … …  
    508514      !!--------------------------------------------------------------------- 
    509515 
    510       max_cons_err =  1.0          ! maximum tolerated conservation error 
    511       max_surf_err =  0.001        ! maximum tolerated surface error 
     516      max_cons_err =  1.0_wp          ! maximum tolerated conservation error 
     517      max_surf_err =  0.001_wp        ! maximum tolerated surface error 
    512518 
    513519      !-------------------------- 
    … …  
    539545 
    540546      numce  = 0 
    541       meance = 0.0 
     547      meance = 0._wp 
    542548      DO ji = kideb, kiut 
    543549         IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 
    … …  
    546552         ENDIF 
    547553      END DO 
    548       IF( numce .GT. 0 ) meance = meance / numce 
     554      IF( numce > 0 )  meance = meance / numce 
    549555 
    550556      WRITE(numout,*) ' Maximum tolerated conservation error : ', max_cons_err 
    … …  
    557563      !------------------------------------------------------- 
    558564      numce  = 0 
    559       meance = 0.0 
     565      meance = 0._wp 
    560566 
    561567      DO ji = kideb, kiut 
    … …  
    566572         ENDIF 
    567573      ENDDO 
    568       IF( numce .GT. 0 ) meance = meance / numce 
     574      IF( numce > 0 )  meance = meance / numce 
    569575 
    570576      WRITE(numout,*) ' Maximum tolerated surface error : ', max_surf_err 
    … …  
    639645 
    640646         ENDIF 
    641  
     647         ! 
    642648      END DO 
    643649      ! 
    … …  
    651657      !! ** Purpose :   Test energy conservation after enthalpy redistr. 
    652658      !!----------------------------------------------------------------------- 
    653       INTEGER, INTENT(in) ::        & 
    654          kideb, kiut,               &  !: bounds for the spatial loop 
    655          jl                            !: category number 
    656  
    657       REAL(wp)                 ::   &  !: ! goes to trash 
    658          meance,                    &  !: mean conservation error 
    659          max_cons_err                  !: maximum tolerated conservation error 
    660  
    661       INTEGER ::                    & 
    662          numce                         !: number of points for which conservation 
    663       !  is violated 
    664       INTEGER  ::  ji, zji, zjj        ! loop indices 
     659      INTEGER, INTENT(in) ::   kideb, kiut   ! bounds for the spatial loop 
     660      INTEGER, INTENT(in) ::   jl            ! category number 
     661      ! 
     662      INTEGER  ::   ji                ! loop indices 
     663      INTEGER  ::   zji, zjj, numce         ! local integers 
     664      REAL(wp) ::   meance, max_cons_err    !local scalar 
    665665      !!--------------------------------------------------------------------- 
    666666 
    667       max_cons_err = 1.0 
     667      max_cons_err = 1._wp 
    668668 
    669669      !-------------------------- 
    670670      ! Increment of energy 
    671671      !-------------------------- 
    672       ! global 
    673       DO ji = kideb, kiut 
    674          dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl)  & 
    675             + qt_s_fin(ji,jl) - qt_s_in(ji,jl) 
    676       END DO 
    677       ! layer by layer 
    678       dq_i_layer(:,:)    = q_i_layer_fin(:,:) - q_i_layer_in(:,:) 
     672      DO ji = kideb, kiut 
     673         dq_i(ji,jl) = qt_i_fin(ji,jl) - qt_i_in(ji,jl) + qt_s_fin(ji,jl) - qt_s_in(ji,jl)   ! global 
     674      END DO 
     675      dq_i_layer(:,:)    = q_i_layer_fin(:,:) - q_i_layer_in(:,:)                            ! layer by layer 
    679676 
    680677      !---------------------------------------- 
    681678      ! Atmospheric heat flux, ice heat budget 
    682679      !---------------------------------------- 
    683  
    684       DO ji = kideb, kiut 
    685          zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    686          zjj                 = ( npb(ji) - 1 ) / jpi + 1 
    687  
    688          fatm(ji,jl) = & 
    689             qnsr_ice_1d(ji)                  + & ! atm non solar 
    690             !         (1.0-i0(ji))*qsr_ice_1d(ji)          ! atm solar 
    691             qsr_ice_1d(ji)                       ! atm solar 
    692  
    693          sum_fluxq(ji,jl)     = fatm(ji,jl) + fbif_1d(ji) - ftotal_fin(ji) &  
    694             - fstroc(zji,zjj,jl)  
    695          cons_error(ji,jl)   = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 
     680      DO ji = kideb, kiut 
     681         zji = MOD( npb(ji) - 1 , jpi ) + 1 
     682         zjj =    ( npb(ji) - 1 ) / jpi + 1 
     683 
     684         fatm      (ji,jl) = qnsr_ice_1d(ji) + qsr_ice_1d(ji)                       ! total heat flux 
     685         sum_fluxq (ji,jl) = fatm(ji,jl) + fbif_1d(ji) - ftotal_fin(ji) - fstroc(zji,zjj,jl)  
     686         cons_error(ji,jl) = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 
    696687      END DO 
    697688 
    … …  
    699690      ! Conservation error 
    700691      !-------------------- 
    701  
    702692      DO ji = kideb, kiut 
    703693         cons_error(ji,jl) = ABS( dq_i(ji,jl) / rdt_ice + sum_fluxq(ji,jl) ) 
    … …  
    705695 
    706696      numce = 0 
    707       meance = 0.0 
    708       DO ji = kideb, kiut 
    709          IF ( cons_error(ji,jl) .GT. max_cons_err ) THEN 
     697      meance = 0._wp 
     698      DO ji = kideb, kiut 
     699         IF( cons_error(ji,jl) .GT. max_cons_err ) THEN 
    710700            numce = numce + 1 
    711701            meance = meance + cons_error(ji,jl) 
    712702         ENDIF 
    713703      ENDDO 
    714       IF (numce .GT. 0 ) meance = meance / numce 
     704      IF(numce > 0 ) meance = meance / numce 
    715705 
    716706      WRITE(numout,*) ' Error report - Category : ', jl 
    … …  
    718708      WRITE(numout,*) ' Maximum tolerated conservation error : ', max_cons_err 
    719709      WRITE(numout,*) ' After lim_thd_ent, category : ', jl 
    720       WRITE(numout,*) ' Mean conservation error on big error points ', meance, & 
    721          numit 
     710      WRITE(numout,*) ' Mean conservation error on big error points ', meance, numit 
    722711      WRITE(numout,*) ' Number of points where there is a cons err gt than 0.1 W/m2 : ', numce, numit 
    723712 
    … …  
    727716      DO ji = kideb, kiut 
    728717         IF ( cons_error(ji,jl) .GT. max_cons_err  ) THEN 
    729             zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    730             zjj                 = ( npb(ji) - 1 ) / jpi + 1 
     718            zji = MOD( npb(ji) - 1, jpi ) + 1 
     719            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    731720            ! 
    732721            WRITE(numout,*) ' alerte 1 - category : ', jl 
    … …  
    779768      INTEGER, INTENT(in) ::   kideb, kiut   ! bounds for the spatial loop 
    780769      !! 
    781       INTEGER  ::   ji, jk   !dummy loop indices 
    782       REAL(wp) ::   ztmelts, zeps   ! temporary scalar  
     770      INTEGER  ::   ji, jk   ! dummy loop indices 
     771      REAL(wp) ::   ztmelts  ! local scalar  
    783772      !!------------------------------------------------------------------- 
    784       zeps = 1.e-10 
    785773      ! 
    786774      DO jk = 1, nlay_i             ! Sea ice energy of melting 
    … …  
    788776            ztmelts      =  - tmut  * s_i_b(ji,jk) + rtt  
    789777            q_i_b(ji,jk) =    rhoic * ( cpic * ( ztmelts - t_i_b(ji,jk) )                                 & 
    790                &                      + lfus * ( 1.0 - (ztmelts-rtt) / MIN( t_i_b(ji,jk)-rtt, -zeps ) )   & 
     778               &                      + lfus * ( 1.0 - (ztmelts-rtt) / MIN( t_i_b(ji,jk)-rtt, -epsi10 ) )   & 
    791779               &                      - rcp  * ( ztmelts-rtt  )  )  
    792780         END DO 
    793781      END DO 
    794782      DO jk = 1, nlay_s             ! Snow energy of melting 
    795          DO ji = kideb,kiut 
     783         DO ji = kideb, kiut 
    796784            q_s_b(ji,jk) = rhosn * ( cpic * ( rtt - t_s_b(ji,jk) ) + lfus ) 
    797785         END DO 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd_dh.F90

    r2528 r2612  
    77   !!                 ! 2005-06 (M. Vancoppenolle) 3D version  
    88   !!            3.2  ! 2009-07 (M. Vancoppenolle, Y. Aksenov, G. Madec) bug correction in rdmsnif & rdmicif 
     9   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    910   !!---------------------------------------------------------------------- 
    1011#if defined key_lim3 
    … …  
    1718   USE phycst           ! physical constants (OCE directory)  
    1819   USE sbc_oce          ! Surface boundary condition: ocean fields 
    19    USE ice 
    20    USE par_ice 
    21    USE thd_ice 
    22    USE in_out_manager 
    23    USE lib_mpp 
     20   USE ice              ! LIM variables 
     21   USE par_ice          ! LIM parameters 
     22   USE thd_ice          ! LIM thermodynamics 
     23   USE wrk_nemo         ! workspace manager 
     24   USE in_out_manager   ! I/O manager 
     25   USE lib_mpp          ! MPP library 
    2426 
    2527   IMPLICIT NONE 
    … …  
    3537 
    3638   !!---------------------------------------------------------------------- 
    37    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     39   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2010) 
    3840   !! $Id$ 
    39    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     41   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4042   !!---------------------------------------------------------------------- 
    41  
    4243CONTAINS 
    4344 
    44    SUBROUTINE lim_thd_dh(kideb,kiut,jl) 
     45   SUBROUTINE lim_thd_dh( kideb, kiut, jl ) 
    4546      !!------------------------------------------------------------------ 
    4647      !!                ***  ROUTINE lim_thd_dh  *** 
    … …  
    7576      INTEGER  ::   i_ice_switch   ! ice thickness above a certain treshold or not 
    7677      INTEGER  ::   iter 
    77  
    78       REAL(wp) ::   zzfmass_i, zzfmass_s   ! temporary scalar 
    79       REAL(wp) ::   zhsnew, zihgnew, ztmelts               ! temporary scalar 
     78      INTEGER  ::   num_iter_max, numce_dh 
     79 
     80      REAL(wp) ::   meance_dh 
     81      REAL(wp) ::   zzfmass_i, zihgnew                     ! local scalar 
     82      REAL(wp) ::   zzfmass_s, zhsnew, ztmelts             ! local scalar 
    8083      REAL(wp) ::   zhn, zdhcf, zdhbf, zhni, zhnfi, zihg   ! 
    81       REAL(wp) ::   zdhnm, zhnnew, zhisn, zihic            ! 
     84      REAL(wp) ::   zdhnm, zhnnew, zhisn, zihic, zzc       ! 
    8285      REAL(wp) ::   zfracs       ! fractionation coefficient for bottom salt entrapment 
    8386      REAL(wp) ::   zds          ! increment of bottom ice salinity 
    … …  
    8992      REAL(wp) ::   zgrr         ! bottom growth rate 
    9093      REAL(wp) ::   ztform       ! bottom formation temperature 
    91  
    92       REAL(wp), DIMENSION(jpij) ::   zh_i        ! ice layer thickness 
    93       REAL(wp), DIMENSION(jpij) ::   zh_s        ! snow layer thickness 
    94       REAL(wp), DIMENSION(jpij) ::   ztfs        ! melting point 
    95       REAL(wp), DIMENSION(jpij) ::   zhsold      ! old snow thickness 
    96       REAL(wp), DIMENSION(jpij) ::   zqprec      ! energy of fallen snow 
    97       REAL(wp), DIMENSION(jpij) ::   zqfont_su   ! incoming, remaining surface energy 
    98       REAL(wp), DIMENSION(jpij) ::   zqfont_bo   ! incoming, bottom energy 
    99       REAL(wp), DIMENSION(jpij) ::   z_f_surf    ! surface heat for ablation 
    100       REAL(wp), DIMENSION(jpij) ::   zhgnew      ! new ice thickness 
    101       REAL(wp), DIMENSION(jpij) ::   zfmass_i    !  
    102  
    103       REAL(wp), DIMENSION(jpij) ::   zdh_s_mel     ! snow melt  
    104       REAL(wp), DIMENSION(jpij) ::   zdh_s_pre     ! snow precipitation  
    105       REAL(wp), DIMENSION(jpij) ::   zdh_s_sub     ! snow sublimation 
    106       REAL(wp), DIMENSION(jpij) ::   zfsalt_melt   ! salt flux due to ice melt 
    107  
    108       REAL(wp) , DIMENSION(jpij,jkmax) ::   zdeltah 
    109  
    110       ! Pathological cases 
    111       REAL(wp), DIMENSION(jpij) ::   zfdt_init   ! total incoming heat for ice melt 
    112       REAL(wp), DIMENSION(jpij) ::   zfdt_final  ! total remaing heat for ice melt 
    113       REAL(wp), DIMENSION(jpij) ::   zqt_i       ! total ice heat content 
    114       REAL(wp), DIMENSION(jpij) ::   zqt_s       ! total snow heat content 
    115       REAL(wp), DIMENSION(jpij) ::   zqt_dummy   ! dummy heat content 
    116  
     94      ! 
     95      REAL(wp), POINTER, DIMENSION(:) ::   zh_i, ztfs  , zqfont_su, zqprec  , zhgnew 
     96      REAL(wp), POINTER, DIMENSION(:) ::   zh_s, zhsold, zqfont_bo, z_f_surf, zfmass_i 
     97      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_mel, zdh_s_sub  , zfdt_init , zqt_i, zqt_dummy, zdq_i 
     98      REAL(wp), POINTER, DIMENSION(:) ::   zdh_s_pre, zfsalt_melt, zfdt_final, zqt_s, zfbase   , zinnermelt 
     99      ! 
     100      REAL(wp), DIMENSION(jpij,jkmax) ::   zdeltah 
    117101      REAL(wp), DIMENSION(jpij,jkmax) ::   zqt_i_lay   ! total ice heat content 
    118  
    119       ! Heat conservation  
    120       INTEGER  ::   num_iter_max, numce_dh 
    121       REAL(wp) ::   meance_dh 
    122       INTEGER , DIMENSION(jpij) ::   innermelt 
    123       REAL(wp), DIMENSION(jpij) ::   zfbase, zdq_i 
    124102      !!------------------------------------------------------------------ 
    125103 
    126       zfsalt_melt(:)  = 0.0 
    127       ftotal_fin(:)   = 0.0 
    128       zfdt_init(:)    = 0.0 
    129       zfdt_final(:)   = 0.0 
     104      IF( .NOT. wrk_use(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22) ) THEN 
     105         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN 
     106      END IF 
     107      ! Set-up pointers to sub-arrays of workspace arrays 
     108      zh_i        => wrk_1d_1 (1:jpij)   ! ice layer thickness 
     109      zh_s        => wrk_1d_2 (1:jpij)   ! snow layer thickness 
     110      ztfs        => wrk_1d_3 (1:jpij)   ! melting point 
     111      zhsold      => wrk_1d_4 (1:jpij)   ! old snow thickness 
     112      zqprec      => wrk_1d_5 (1:jpij)   ! energy of fallen snow 
     113      zqfont_su   => wrk_1d_6 (1:jpij)   ! incoming, remaining surface energy 
     114      zqfont_bo   => wrk_1d_7 (1:jpij)   ! incoming, bottom energy 
     115      z_f_surf    => wrk_1d_8 (1:jpij)   ! surface heat for ablation 
     116      zhgnew      => wrk_1d_9 (1:jpij)   ! new ice thickness 
     117      zfmass_i    => wrk_1d_10(1:jpij)   !  
     118      ! 
     119      zdh_s_mel   => wrk_1d_11(1:jpij)   ! snow melt  
     120      zdh_s_pre   => wrk_1d_12(1:jpij)   ! snow precipitation  
     121      zdh_s_sub   => wrk_1d_13(1:jpij)   ! snow sublimation 
     122      zfsalt_melt => wrk_1d_14(1:jpij)   ! salt flux due to ice melt 
     123      ! 
     124      !                              ! Pathological cases 
     125      zfdt_init   => wrk_1d_15(1:jpij)   ! total incoming heat for ice melt 
     126      zfdt_final  => wrk_1d_16(1:jpij)   ! total remaing heat for ice melt 
     127      zqt_i       => wrk_1d_17(1:jpij)   ! total ice heat content 
     128      zqt_s       => wrk_1d_18(1:jpij)   ! total snow heat content 
     129      zqt_dummy   => wrk_1d_19(1:jpij)   ! dummy heat content 
     130            
     131      zfbase      => wrk_1d_20(1:jpij)         
     132      zdq_i       => wrk_1d_21(1:jpij)  
     133      zinnermelt  => wrk_1d_22(1:jpij)  
     134 
     135      zfsalt_melt(:)  = 0._wp 
     136      ftotal_fin(:)   = 0._wp 
     137      zfdt_init(:)    = 0._wp 
     138      zfdt_final(:)   = 0._wp 
    130139 
    131140      DO ji = kideb, kiut 
    … …  
    138147      !------------------------------------------------------------------------------! 
    139148      ! 
    140       DO ji = kideb,kiut 
     149      DO ji = kideb, kiut 
    141150         isnow         = INT( 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s_b(ji) ) ) ) 
    142151         ztfs(ji)      = isnow * rtt + ( 1.0 - isnow ) * rtt 
    … …  
    146155      END DO ! ji 
    147156 
    148       zqfont_su(:) = 0.0 
    149       zqfont_bo(:) = 0.0 
    150       dsm_i_se_1d(:) = 0.0      
    151       dsm_i_si_1d(:) = 0.0      
     157      zqfont_su  (:) = 0._wp 
     158      zqfont_bo  (:) = 0._wp 
     159      dsm_i_se_1d(:) = 0._wp      
     160      dsm_i_si_1d(:) = 0._wp    
    152161      ! 
    153162      !------------------------------------------------------------------------------! 
    … …  
    155164      !------------------------------------------------------------------------------! 
    156165      ! 
    157       ! Layer thickness 
    158       DO ji = kideb,kiut 
     166      DO ji = kideb, kiut     ! Layer thickness 
    159167         zh_i(ji) = ht_i_b(ji) / nlay_i 
    160168         zh_s(ji) = ht_s_b(ji) / nlay_s 
    161169      END DO 
    162  
    163       ! Total enthalpy of the snow 
    164       zqt_s(:) = 0.0 
     170      ! 
     171      zqt_s(:) = 0._wp        ! Total enthalpy of the snow 
    165172      DO jk = 1, nlay_s 
    166          DO ji = kideb,kiut 
     173         DO ji = kideb, kiut 
    167174            zqt_s(ji) =  zqt_s(ji) + q_s_b(ji,jk) * ht_s_b(ji) / nlay_s 
    168175         END DO 
    169176      END DO 
    170  
    171       ! Total enthalpy of the ice 
    172       zqt_i(:) = 0.0 
     177      ! 
     178      zqt_i(:) = 0._wp        ! Total enthalpy of the ice 
    173179      DO jk = 1, nlay_i 
    174          DO ji = kideb,kiut 
    175             zqt_i(ji)        =  zqt_i(ji) + q_i_b(ji,jk) * ht_i_b(ji) / nlay_i 
    176             zqt_i_lay(ji,jk) =              q_i_b(ji,jk) * ht_i_b(ji) / nlay_i 
     180         DO ji = kideb, kiut 
     181            zzc = q_i_b(ji,jk) * ht_i_b(ji) / nlay_i 
     182            zqt_i(ji)        =  zqt_i(ji) + zzc 
     183            zqt_i_lay(ji,jk) =              zzc 
    177184         END DO 
    178185      END DO 
    … …  
    201208         zdh_s_pre(ji) = zcoeff * sprecip_1d(ji) * rdt_ice / rhosn 
    202209      END DO 
    203       zdh_s_mel(:) =  0.0 
     210      zdh_s_mel(:) =  0._wp 
    204211 
    205212      ! Melt of fallen snow 
    … …  
    248255      !-------------------------- 
    249256      DO ji = kideb, kiut  
    250          dh_i_surf(ji) =  0.e0 
     257         dh_i_surf(ji) =  0._wp 
    251258         z_f_surf (ji) =  zqfont_su(ji) / rdt_ice ! heat conservation test 
    252          zdq_i    (ji) =  0.e0 
     259         zdq_i    (ji) =  0._wp 
    253260      END DO ! ji 
    254261 
    … …  
    267274            ! 
    268275            ! contribution to ice-ocean salt flux  
    269             zji = MOD( npb(ji) - 1, jpi ) + 1 
    270             zjj = ( npb(ji) - 1 ) / jpi + 1 
     276            zji = MOD( npb(ji) - 1 , jpi ) + 1 
     277            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    271278            zfsalt_melt(ji) = zfsalt_melt(ji) + ( sss_m(zji,zjj) - sm_i_b(ji) ) * a_i_b(ji)    & 
    272279               &                              * MIN( zdeltah(ji,jk) , 0.e0 ) * rhoic / rdt_ice  
    … …  
    278285         !                  !------------------- 
    279286         numce_dh  = 0 
    280          meance_dh = 0.e0 
     287         meance_dh = 0._wp 
    281288         DO ji = kideb, kiut 
    282289            IF ( ( z_f_surf(ji) + zdq_i(ji) ) .GE. 1.0e-3 ) THEN 
    … …  
    287294               WRITE(numout,*) ' ALERTE heat loss for surface melt ' 
    288295               WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl 
    289                WRITE(numout,*) ' ht_i_b  : ', ht_i_b(ji) 
    290                WRITE(numout,*) ' z_f_surf  : ', z_f_surf(ji) 
    291                WRITE(numout,*) ' zdq_i   : ', zdq_i(ji) 
    292                WRITE(numout,*) ' ht_i_b  : ', ht_i_b(ji) 
    293                WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji) 
    294                WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji) 
    295                WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji) 
    296                WRITE(numout,*) ' s_i_new : ', s_i_new(ji) 
    297                WRITE(numout,*) ' sss_m   : ', sss_m(zji,zjj) 
     296               WRITE(numout,*) ' ht_i_b       : ', ht_i_b(ji) 
     297               WRITE(numout,*) ' z_f_surf     : ', z_f_surf(ji) 
     298               WRITE(numout,*) ' zdq_i        : ', zdq_i(ji) 
     299               WRITE(numout,*) ' ht_i_b       : ', ht_i_b(ji) 
     300               WRITE(numout,*) ' fc_bo_i      : ', fc_bo_i(ji) 
     301               WRITE(numout,*) ' fbif_1d      : ', fbif_1d(ji) 
     302               WRITE(numout,*) ' qlbbq_1d     : ', qlbbq_1d(ji) 
     303               WRITE(numout,*) ' s_i_new      : ', s_i_new(ji) 
     304               WRITE(numout,*) ' sss_m        : ', sss_m(zji,zjj) 
    298305            ENDIF 
    299306         END DO 
    … …  
    440447      ! 4.2 Basal melt 
    441448      !---------------- 
    442       meance_dh = 0.0 
     449      meance_dh = 0._wp 
    443450      numce_dh  = 0 
    444       innermelt(:) = 0 
     451      zinnermelt(:) = 0._wp 
    445452 
    446453      DO ji = kideb, kiut 
    447454         ! heat convergence at the surface > 0 
    448          IF(  ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) >= 0.e0  ) THEN 
    449  
     455         IF(  ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) >= 0._wp  ) THEN 
    450456            s_i_new(ji)   =  s_i_b(ji,nlay_i) 
    451457            zqfont_bo(ji) =  rdt_ice * ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) 
    452  
    453             zfbase(ji)    =  zqfont_bo(ji) / rdt_ice ! heat conservation test 
    454             zdq_i(ji)     =  0.e0 
    455  
    456             dh_i_bott(ji) =  0.e0 
     458            zfbase(ji)    =  zqfont_bo(ji) / rdt_ice     ! heat conservation test 
     459            zdq_i(ji)     =  0._wp 
     460            dh_i_bott(ji) =  0._wp 
    457461         ENDIF 
    458462      END DO 
    … …  
    461465         DO ji = kideb, kiut 
    462466            IF (  ( fc_bo_i(ji) + fbif_1d(ji) + qlbbq_1d(ji) ) .GE. 0.0  ) THEN 
    463                ztmelts             =   - tmut * s_i_b(ji,jk) + rtt  
    464                IF ( t_i_b(ji,jk) .GE. ztmelts ) THEN 
     467               ztmelts            =   - tmut * s_i_b(ji,jk) + rtt  
     468               IF( t_i_b(ji,jk) >= ztmelts ) THEN 
    465469                  zdeltah(ji,jk)  = - zh_i(ji) 
    466470                  dh_i_bott(ji)   = dh_i_bott(ji) + zdeltah(ji,jk) 
    467                   innermelt(ji)   = 1 
     471                  zinnermelt(ji)   = 1._wp 
    468472               ELSE  ! normal ablation 
    469473                  zdeltah(ji,jk)  = - zqfont_bo(ji) / q_i_b(ji,jk) 
    … …  
    492496               ENDIF 
    493497               IF ( zfbase(ji) + zdq_i(ji) .GE. 1.0e-3  ) THEN 
    494                   WRITE(numout,*) ' ALERTE heat loss for basal  melt ' 
    495                   WRITE(numout,*) ' zji, zjj, jl :', zji, zjj, jl 
    496                   WRITE(numout,*) ' ht_i_b  : ', ht_i_b(ji) 
    497                   WRITE(numout,*) ' zfbase  : ', zfbase(ji) 
    498                   WRITE(numout,*) ' zdq_i   : ', zdq_i(ji) 
    499                   WRITE(numout,*) ' ht_i_b  : ', ht_i_b(ji) 
    500                   WRITE(numout,*) ' fc_bo_i : ', fc_bo_i(ji) 
    501                   WRITE(numout,*) ' fbif_1d : ', fbif_1d(ji) 
    502                   WRITE(numout,*) ' qlbbq_1d: ', qlbbq_1d(ji) 
    503                   WRITE(numout,*) ' s_i_new : ', s_i_new(ji) 
    504                   WRITE(numout,*) ' sss_m   : ', sss_m(zji,zjj) 
     498                  WRITE(numout,*) ' ALERTE heat loss for basal melt : zji, zjj, jl :', zji, zjj, jl 
     499                  WRITE(numout,*) ' ht_i_b    : ', ht_i_b(ji) 
     500                  WRITE(numout,*) ' zfbase    : ', zfbase(ji) 
     501                  WRITE(numout,*) ' zdq_i     : ', zdq_i(ji) 
     502                  WRITE(numout,*) ' ht_i_b    : ', ht_i_b(ji) 
     503                  WRITE(numout,*) ' fc_bo_i   : ', fc_bo_i(ji) 
     504                  WRITE(numout,*) ' fbif_1d   : ', fbif_1d(ji) 
     505                  WRITE(numout,*) ' qlbbq_1d  : ', qlbbq_1d(ji) 
     506                  WRITE(numout,*) ' s_i_new   : ', s_i_new(ji) 
     507                  WRITE(numout,*) ' sss_m     : ', sss_m(zji,zjj) 
    505508                  WRITE(numout,*) ' dh_i_bott : ', dh_i_bott(ji) 
    506                   WRITE(numout,*) ' innermelt : ', innermelt(ji) 
     509                  WRITE(numout,*) ' innermelt : ', INT( zinnermelt(ji) ) 
    507510               ENDIF 
    508511            ENDIF 
    … …  
    687690 
    688691         ! Total ablation ! new lines added to debug 
    689          IF( ht_i_b(ji) <= 0.e0 )   a_i_b(ji) = 0.0 
     692         IF( ht_i_b(ji) <= 0._wp )   a_i_b(ji) = 0._wp 
    690693 
    691694         ! diagnostic ( snow ice growth ) 
    … …  
    695698         ! 
    696699      END DO !ji 
    697  
     700      ! 
     701      IF( .NOT. wrk_release(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21) )   & 
     702         &     CALL ctl_stop('lim_thd_dh : failed to release workspace arrays.') 
     703      ! 
    698704   END SUBROUTINE lim_thd_dh 
    699705    

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd_dif.F90

    r2528 r2612  
    55   !!                   computation of surface and inner T   
    66   !!====================================================================== 
     7   !! History :  LIM  ! 02-2003 (M. Vancoppenolle) original 1D code 
     8   !!                 ! 06-2005 (M. Vancoppenolle) 3d version 
     9   !!                 ! 11-2006 (X Fettweis) Vectorization by Xavier 
     10   !!                 ! 04-2007 (M. Vancoppenolle) Energy conservation 
     11   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    712   !!---------------------------------------------------------------------- 
    813#if defined key_lim3 
    … …  
    1217   USE par_oce          ! ocean parameters 
    1318   USE phycst           ! physical constants (ocean directory)  
    14    USE thd_ice 
    15    USE in_out_manager 
    16    USE ice 
    17    USE par_ice 
    18    USE lib_mpp  
     19   USE ice              ! LIM-3 variables 
     20   USE par_ice          ! LIM-3 parameters 
     21   USE thd_ice          ! LIM-3: thermodynamics 
     22   USE in_out_manager   ! I/O manager 
     23   USE lib_mpp          ! MPP library 
    1924 
    2025   IMPLICIT NONE 
    … …  
    2328   PUBLIC   lim_thd_dif   ! called by lim_thd 
    2429 
    25    REAL(wp)  ::           &  ! constant values 
    26       epsi20 = 1e-20   ,  & 
    27       epsi13 = 1e-13   ,  & 
    28       zzero  = 0.e0    ,  & 
    29       zone   = 1.e0 
     30   REAL(wp) ::   epsi20 = 1e-20     ! constant values 
     31   REAL(wp) ::   epsi13 = 1e-13     ! constant values 
    3032 
    3133   !!---------------------------------------------------------------------- 
    32    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     34   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3335   !! $Id$ 
    34    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     36   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    3537   !!---------------------------------------------------------------------- 
    3638CONTAINS 
    … …  
    7779      !!           profile of the ice/snow layers : z_i, z_s 
    7880      !!           total ice/snow thickness : ht_i_b, ht_s_b 
    79       !! 
    80       !! ** External :  
    81       !! 
    82       !! ** References : 
    83       !! 
    84       !! ** History : 
    85       !!           (02-2003) Martin Vancoppenolle, Louvain-la-Neuve, Belgium 
    86       !!           (06-2005) Martin Vancoppenolle, 3d version 
    87       !!           (11-2006) Vectorized by Xavier Fettweis (UCL-ASTR) 
    88       !!           (04-2007) Energy conservation tested by M. Vancoppenolle 
    89       !! 
    9081      !!------------------------------------------------------------------ 
    91       !! * Arguments 
    92  
    9382      INTEGER , INTENT (in) ::  & 
    9483         kideb ,  &  ! Start point on which the  the computation is applied 
    … …  
    9887      !! * Local variables 
    9988      INTEGER ::   ji,       &   ! spatial loop index 
    100          zji, zjj, &   ! temporary dummy loop index 
     89         ii, ij, &   ! temporary dummy loop index 
    10190         numeq,    &   ! current reference number of equation 
    10291         layer,    &   ! vertical dummy loop index  
    10392         nconv,    &   ! number of iterations in iterative procedure 
    104          minnumeqmin, & ! 
    105          maxnumeqmax 
     93         minnumeqmin, maxnumeqmax 
    10694 
    10795      INTEGER , DIMENSION(kiut) :: & 
    … …  
    140128         zdiagbis 
    141129 
    142       REAL(wp) , DIMENSION(kiut,jkmax+2,3) ::  & 
    143          ztrid          ! tridiagonal system terms 
     130      REAL(wp) , DIMENSION(kiut,jkmax+2,3) ::   ztrid   ! tridiagonal system terms 
    144131 
    145132      REAL(wp), DIMENSION(kiut) ::  & 
    146133         ztfs     ,   & ! ice melting point 
    147          ztsuold  ,   & ! old surface temperature (before the iterative 
    148                                 !          procedure ) 
     134         ztsuold  ,   & ! old surface temperature (before the iterative procedure ) 
    149135         ztsuoldit,   & ! surface temperature at previous iteration 
    150136         zh_i     ,   & !ice layer thickness 
    … …  
    155141 
    156142      REAL(wp)  ::           &  ! constant values 
    157          zeps      =  1.0e-10,   & ! 
    158          zg1s      =  2.0,       & !: for the tridiagonal system 
    159          zg1       =  2.0,       & 
    160          zgamma    =  18009.0,   & !: for specific heat 
    161          zbeta     =  0.117,     & !: for thermal conductivity (could be 0.13) 
    162          zraext_s  =  1.0e08,    & !: extinction coefficient of radiation in the snow 
    163          zkimin    =  0.10 ,     & !: minimum ice thermal conductivity 
    164          zht_smin  =  1.0e-4       !: minimum snow depth 
    165  
    166       REAL(wp)  ::          &  ! local variables  
    167          ztmelt_i,           &  ! ice melting temperature 
    168          zerritmax              ! current maximal error on temperature  
    169  
    170       REAL(wp), DIMENSION(kiut)  :: & 
    171          zerrit,             &  ! current error on temperature  
    172          zdifcase,           &  ! case of the equation resolution (1->4) 
    173          zftrice,            &  ! solar radiation transmitted through the ice 
    174          zihic, zhsu 
    175  
     143         zeps      =  1.e-10_wp,   & ! 
     144         zg1s      =  2._wp,       & !: for the tridiagonal system 
     145         zg1       =  2._wp,       & 
     146         zgamma    =  18009._wp,   & !: for specific heat 
     147         zbeta     =  0.117_wp,    & !: for thermal conductivity (could be 0.13) 
     148         zraext_s  =  1.e+8_wp,    & !: extinction coefficient of radiation in the snow 
     149         zkimin    =  0.10_wp ,    & !: minimum ice thermal conductivity 
     150         zht_smin  =  1.e-4_wp       !: minimum snow depth 
     151 
     152      REAL(wp) ::   ztmelt_i    ! ice melting temperature 
     153      REAL(wp) ::   zerritmax   ! current maximal error on temperature  
     154 
     155      REAL(wp), DIMENSION(kiut) ::   zerrit       ! current error on temperature  
     156      REAL(wp), DIMENSION(kiut) ::   zdifcase     ! case of the equation resolution (1->4) 
     157      REAL(wp), DIMENSION(kiut) ::   zftrice      ! solar radiation transmitted through the ice 
     158      REAL(wp), DIMENSION(kiut) ::   zihic, zhsu 
     159      !!------------------------------------------------------------------ 
    176160      ! 
    177161      !------------------------------------------------------------------------------! 
    … …  
    181165      DO ji = kideb , kiut 
    182166         ! is there snow or not 
    183          isnow(ji)= INT ( 1.0 - MAX( 0.0 , SIGN (1.0, - ht_s_b(ji) ) ) ) 
     167         isnow(ji)= INT(  1._wp - MAX( 0._wp , SIGN(1._wp, - ht_s_b(ji) ) ) ) 
    184168         ! surface temperature of fusion 
     169!!gm ???  ztfs(ji) = rtt !!!???? 
    185170         ztfs(ji) = isnow(ji) * rtt + (1.0-isnow(ji)) * rtt 
    186171         ! layer thickness 
    187          zh_i(ji)              = ht_i_b(ji) / nlay_i 
    188          zh_s(ji)              = ht_s_b(ji) / nlay_s 
     172         zh_i(ji) = ht_i_b(ji) / nlay_i 
     173         zh_s(ji) = ht_s_b(ji) / nlay_s 
    189174      END DO 
    190175 
    … …  
    193178      !-------------------- 
    194179 
    195       z_s(:,0)      = 0.0 ! vert. coord. of the up. lim. of the 1st snow layer 
    196       z_i(:,0)      = 0.0 ! vert. coord. of the up. lim. of the 1st ice layer 
    197  
    198       DO layer = 1, nlay_s 
    199          DO ji = kideb , kiut 
    200             ! vert. coord of the up. lim. of the layer-th snow layer 
    201             z_s(ji,layer)      = z_s(ji,layer-1) + ht_s_b(ji) / nlay_s 
    202          END DO 
    203       END DO 
    204  
    205       DO layer = 1, nlay_i 
    206          DO ji = kideb , kiut 
    207             ! vert. coord of the up. lim. of the layer-th ice layer 
    208             z_i(ji,layer)      = z_i(ji,layer-1) + ht_i_b(ji) / nlay_i 
     180      z_s(:,0) = 0._wp   ! vert. coord. of the up. lim. of the 1st snow layer 
     181      z_i(:,0) = 0._wp   ! vert. coord. of the up. lim. of the 1st ice layer 
     182 
     183      DO layer = 1, nlay_s            ! vert. coord of the up. lim. of the layer-th snow layer 
     184         DO ji = kideb , kiut 
     185            z_s(ji,layer) = z_s(ji,layer-1) + ht_s_b(ji) / nlay_s 
     186         END DO 
     187      END DO 
     188 
     189      DO layer = 1, nlay_i            ! vert. coord of the up. lim. of the layer-th ice layer 
     190         DO ji = kideb , kiut 
     191            z_i(ji,layer) = z_i(ji,layer-1) + ht_i_b(ji) / nlay_i 
    209192         END DO 
    210193      END DO 
    … …  
    227210      DO ji = kideb , kiut 
    228211         ! switches 
    229          isnow(ji)  = INT ( 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_s_b(ji) ) ) )  
     212         isnow(ji) = INT(  1._wp - MAX( 0._wp , SIGN( 1._wp , - ht_s_b(ji) ) ) )  
    230213         ! hs > 0, isnow = 1 
    231          zhsu(ji)   = hnzst  !threshold for the computation of i0 
    232          zihic(ji)  = MAX( zzero , 1.0 - ( ht_i_b(ji) / zhsu(ji) ) )      
    233  
    234          i0(ji)     = ( 1.0 - isnow(ji) ) * & 
    235             ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 
     214         zhsu (ji) = hnzst  ! threshold for the computation of i0 
     215         zihic(ji) = MAX( 0._wp , 1._wp - ( ht_i_b(ji) / zhsu(ji) ) )      
     216 
     217         i0(ji)    = ( 1._wp - isnow(ji) ) * ( fr1_i0_1d(ji) + zihic(ji) * fr2_i0_1d(ji) ) 
    236218         !fr1_i0_1d = i0 for a thin ice surface 
    237219         !fr1_i0_2d = i0 for a thick ice surface 
    … …  
    247229      !------------------------------------------------------- 
    248230      DO ji = kideb , kiut 
    249  
    250          ! Shortwave radiation absorbed at surface 
    251          zfsw(ji)   =  qsr_ice_1d(ji) * ( 1 - i0(ji) ) 
    252  
    253          ! Solar radiation transmitted below the surface layer 
    254          zftrice(ji)=  qsr_ice_1d(ji) * i0(ji) 
    255  
    256          ! derivative of incoming nonsolar flux  
    257          dzf(ji)   =    dqns_ice_1d(ji)   
    258  
     231         zfsw   (ji) =  qsr_ice_1d(ji) * ( 1 - i0(ji) )   ! Shortwave radiation absorbed at surface 
     232         zftrice(ji) =  qsr_ice_1d(ji) *       i0(ji)     ! Solar radiation transmitted below the surface layer 
     233         dzf    (ji) = dqns_ice_1d(ji)                    ! derivative of incoming nonsolar flux  
    259234      END DO 
    260235 
    … …  
    263238      !--------------------------------------------------------- 
    264239 
    265       DO ji = kideb , kiut 
    266          ! Initialization 
    267          zradtr_s(ji,0) = zftrice(ji) ! radiation penetrating through snow 
    268       END DO 
    269  
    270       ! Radiation through snow 
    271       DO layer = 1, nlay_s 
    272          DO ji = kideb , kiut 
    273             ! radiation transmitted below the layer-th snow layer 
    274             zradtr_s(ji,layer) = zradtr_s(ji,0) * EXP ( - zraext_s * ( MAX ( 0.0 , & 
    275                z_s(ji,layer) ) ) ) 
    276             ! radiation absorbed by the layer-th snow layer 
     240      DO ji = kideb, kiut           ! snow initialization 
     241         zradtr_s(ji,0) = zftrice(ji)     ! radiation penetrating through snow 
     242      END DO 
     243 
     244      DO layer = 1, nlay_s          ! Radiation through snow 
     245         DO ji = kideb, kiut 
     246            !                             ! radiation transmitted below the layer-th snow layer 
     247            zradtr_s(ji,layer) = zradtr_s(ji,0) * EXP( - zraext_s * ( MAX ( 0._wp , z_s(ji,layer) ) ) ) 
     248            !                             ! radiation absorbed by the layer-th snow layer 
    277249            zradab_s(ji,layer) = zradtr_s(ji,layer-1) - zradtr_s(ji,layer) 
    278250         END DO 
    279251      END DO 
    280252 
    281       ! Radiation through ice 
    282       DO ji = kideb , kiut 
    283          zradtr_i(ji,0)        = zradtr_s(ji,nlay_s) * isnow(ji) + &  
    284             zftrice(ji) * ( 1 - isnow(ji) ) 
    285       END DO 
    286  
    287       DO layer = 1, nlay_i 
    288          DO ji = kideb , kiut 
    289             ! radiation transmitted below the layer-th ice layer 
    290             zradtr_i(ji,layer) = zradtr_i(ji,0) * EXP ( - kappa_i * ( MAX ( 0.0 , & 
    291                z_i(ji,layer) ) ) ) 
    292             ! radiation absorbed by the layer-th ice layer 
     253      DO ji = kideb, kiut           ! ice initialization 
     254         zradtr_i(ji,0) = zradtr_s(ji,nlay_s) * isnow(ji) + zftrice(ji) * ( 1._wp - isnow(ji) ) 
     255      END DO 
     256 
     257      DO layer = 1, nlay_i          ! Radiation through ice 
     258         DO ji = kideb, kiut 
     259            !                             ! radiation transmitted below the layer-th ice layer 
     260            zradtr_i(ji,layer) = zradtr_i(ji,0) * EXP( - kappa_i * ( MAX ( 0._wp , z_i(ji,layer) ) ) ) 
     261            !                             ! radiation absorbed by the layer-th ice layer 
    293262            zradab_i(ji,layer) = zradtr_i(ji,layer-1) - zradtr_i(ji,layer) 
    294263         END DO 
    295264      END DO 
    296265 
    297       ! Radiation transmitted below the ice 
    298       DO ji = kideb , kiut 
    299          fstbif_1d(ji)  =  fstbif_1d(ji) + & 
    300             zradtr_i(ji,nlay_i) * a_i_b(ji) / at_i_b(ji) 
     266      DO ji = kideb, kiut           ! Radiation transmitted below the ice 
     267         fstbif_1d(ji) = fstbif_1d(ji) + zradtr_i(ji,nlay_i) * a_i_b(ji) / at_i_b(ji) 
    301268      END DO 
    302269 
    303270      ! +++++ 
    304271      ! just to check energy conservation 
    305       DO ji = kideb , kiut 
    306          zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    307          zjj                 = ( npb(ji) - 1 ) / jpi + 1 
    308          fstroc(zji,zjj,jl)  = & 
    309             zradtr_i(ji,nlay_i) 
     272      DO ji = kideb, kiut 
     273         ii                = MOD( npb(ji) - 1, jpi ) + 1 
     274         ij                = ( npb(ji) - 1 ) / jpi + 1 
     275         fstroc(ii,ij,jl) = zradtr_i(ji,nlay_i) 
    310276      END DO 
    311277      ! +++++ 
    312278 
    313279      DO layer = 1, nlay_i 
    314          DO ji = kideb , kiut 
     280         DO ji = kideb, kiut 
    315281            radab(ji,layer) = zradab_i(ji,layer) 
    316282         END DO 
    … …  
    323289      !------------------------------------------------------------------------------| 
    324290      ! 
    325       ! Old surface temperature 
    326       DO ji = kideb, kiut 
    327          ztsuold(ji)          =  t_su_b(ji) ! temperature at the beg of iter pr. 
    328          ztsuoldit(ji)        =  t_su_b(ji) ! temperature at the previous iter 
    329          t_su_b(ji)           =  MIN(t_su_b(ji),ztfs(ji)-0.00001) !necessary 
    330          zerrit(ji)           =  1000.0     ! initial value of error 
    331       END DO 
    332       !RB Min global ?? 
    333  
    334       ! Old snow temperature 
    335       DO layer = 1, nlay_s 
    336          DO ji = kideb , kiut 
    337             ztsold(ji,layer)     =  t_s_b(ji,layer) 
    338          END DO 
    339       END DO 
    340  
    341       ! Old ice temperature 
    342       DO layer = 1, nlay_i 
    343          DO ji = kideb , kiut 
    344             ztiold(ji,layer)     =  t_i_b(ji,layer) 
    345          END DO 
    346       END DO 
    347  
    348       nconv     =  0         ! number of iterations 
    349       zerritmax =  1000.0    ! maximal value of error on all points 
    350  
    351       DO WHILE ((zerritmax > maxer_i_thd).AND.(nconv < nconv_i_thd)) 
    352  
    353          nconv   =  nconv+1 
    354  
     291      DO ji = kideb, kiut        ! Old surface temperature 
     292         ztsuold  (ji) =  t_su_b(ji)                              ! temperature at the beg of iter pr. 
     293         ztsuoldit(ji) =  t_su_b(ji)                              ! temperature at the previous iter 
     294         t_su_b   (ji) =  MIN( t_su_b(ji), ztfs(ji)-0.00001 )     ! necessary 
     295         zerrit   (ji) =  1000._wp                                ! initial value of error 
     296      END DO 
     297 
     298      DO layer = 1, nlay_s       ! Old snow temperature 
     299         DO ji = kideb , kiut 
     300            ztsold(ji,layer) =  t_s_b(ji,layer) 
     301         END DO 
     302      END DO 
     303 
     304      DO layer = 1, nlay_i       ! Old ice temperature 
     305         DO ji = kideb , kiut 
     306            ztiold(ji,layer) =  t_i_b(ji,layer) 
     307         END DO 
     308      END DO 
     309 
     310      nconv     =  0           ! number of iterations 
     311      zerritmax =  1000._wp    ! maximal value of error on all points 
     312 
     313      DO WHILE ( zerritmax > maxer_i_thd .AND. nconv < nconv_i_thd ) 
     314         ! 
     315         nconv = nconv + 1 
    355316         ! 
    356317         !------------------------------------------------------------------------------| 
    … …  
    358319         !------------------------------------------------------------------------------| 
    359320         ! 
    360          IF ( thcon_i_swi .EQ. 0 ) THEN 
    361             ! Untersteiner (1964) formula 
     321         IF( thcon_i_swi == 0 ) THEN      ! Untersteiner (1964) formula 
    362322            DO ji = kideb , kiut 
    363323               ztcond_i(ji,0)        = rcdic + zbeta*s_i_b(ji,1) / & 
    … …  
    365325               ztcond_i(ji,0)        = MAX(ztcond_i(ji,0),zkimin) 
    366326            END DO 
    367          ENDIF 
    368  
    369          IF ( thcon_i_swi .EQ. 1 ) THEN 
    370             ! Pringle et al formula included, 
    371             ! 2.11 + 0.09 S/T - 0.011.T 
    372             DO ji = kideb , kiut 
    373                ztcond_i(ji,0)        = rcdic + 0.09*s_i_b(ji,1) / & 
    374                   MIN(-zeps,t_i_b(ji,1)-rtt) - & 
    375                   0.011* ( t_i_b(ji,1) - rtt )   
    376                ztcond_i(ji,0)        = MAX(ztcond_i(ji,0),zkimin) 
    377             END DO 
    378          ENDIF 
    379  
    380          IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 
    381327            DO layer = 1, nlay_i-1 
    382328               DO ji = kideb , kiut 
    383329                  ztcond_i(ji,layer) = rcdic + zbeta*( s_i_b(ji,layer) & 
    384                      + s_i_b(ji,layer+1) ) / MIN(-zeps,     & 
     330                     + s_i_b(ji,layer+1) ) / MIN(-2.0*zeps,     & 
    385331                     t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) 
    386332                  ztcond_i(ji,layer)   = MAX(ztcond_i(ji,layer),zkimin) 
    387333               END DO 
    388334            END DO 
    389          ENDIF 
    390  
    391          IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 
    392             DO layer = 1, nlay_i-1 
    393                DO ji = kideb , kiut 
    394                   ztcond_i(ji,layer) = rcdic + 0.09*( s_i_b(ji,layer)   & 
    395                      + s_i_b(ji,layer+1) ) / MIN(-zeps,      & 
    396                      t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt) - & 
    397                      0.011* ( t_i_b(ji,layer) + t_i_b(ji,layer+1) - 2.0*rtt )   
    398                   ztcond_i(ji,layer) = MAX(ztcond_i(ji,layer),zkimin) 
    399                END DO 
    400             END DO 
    401          ENDIF 
    402  
    403          IF ( thcon_i_swi .EQ. 0 ) THEN ! Untersteiner 
    404335            DO ji = kideb , kiut 
    405336               ztcond_i(ji,nlay_i)   = rcdic + zbeta*s_i_b(ji,nlay_i) / & 
    … …  
    409340         ENDIF 
    410341 
    411          IF ( thcon_i_swi .EQ. 1 ) THEN ! Pringle 
    412             DO ji = kideb , kiut 
    413                ztcond_i(ji,nlay_i)   = rcdic + 0.09*s_i_b(ji,nlay_i) / & 
    414                   MIN(-zeps,t_bo_b(ji)-rtt) - & 
    415                   0.011* ( t_bo_b(ji) - rtt )   
    416                ztcond_i(ji,nlay_i)   = MAX(ztcond_i(ji,nlay_i),zkimin) 
     342         IF( thcon_i_swi == 1 ) THEN      ! Pringle et al formula included: 2.11 + 0.09 S/T - 0.011.T 
     343            DO ji = kideb , kiut 
     344               ztcond_i(ji,0) = rcdic + 0.090_wp * s_i_b(ji,1) / MIN( -zeps, t_i_b(ji,1)-rtt )   & 
     345                  &                   - 0.011_wp * ( t_i_b(ji,1) - rtt )   
     346               ztcond_i(ji,0) = MAX( ztcond_i(ji,0), zkimin ) 
     347            END DO 
     348            DO layer = 1, nlay_i-1 
     349               DO ji = kideb , kiut 
     350                  ztcond_i(ji,layer) = rcdic + 0.090_wp * ( s_i_b(ji,layer) + s_i_b(ji,layer+1) )   & 
     351                     &                                  / MIN(-2.0*zeps, t_i_b(ji,layer)+t_i_b(ji,layer+1)-2.0*rtt)   & 
     352                     &                       - 0.0055_wp* ( t_i_b(ji,layer) + t_i_b(ji,layer+1) - 2.0*rtt )   
     353                  ztcond_i(ji,layer) = MAX( ztcond_i(ji,layer), zkimin ) 
     354               END DO 
     355            END DO 
     356            DO ji = kideb , kiut 
     357               ztcond_i(ji,nlay_i) = rcdic + 0.090_wp * s_i_b(ji,nlay_i) / MIN(-zeps,t_bo_b(ji)-rtt)   & 
     358                  &                        - 0.011_wp * ( t_bo_b(ji) - rtt )   
     359               ztcond_i(ji,nlay_i) = MAX( ztcond_i(ji,nlay_i), zkimin ) 
    417360            END DO 
    418361         ENDIF 
    … …  
    735678 
    736679            ! surface temperature 
    737             isnow(ji)            = INT(1.0-max(0.0,sign(1.0,-ht_s_b(ji)))) 
    738             ztsuoldit(ji)        = t_su_b(ji) 
     680            isnow(ji)     = INT(1.0-max(0.0,sign(1.0,-ht_s_b(ji)))) 
     681            ztsuoldit(ji) = t_su_b(ji) 
    739682            IF (t_su_b(ji) .LT. ztfs(ji)) & 
    740                t_su_b(ji)           = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* & 
    741                ( isnow(ji)*t_s_b(ji,1) + & 
    742                (1.0-isnow(ji))*t_i_b(ji,1) ) ) / & 
    743                zdiagbis(ji,numeqmin(ji))   
     683               t_su_b(ji) = ( zindtbis(ji,numeqmin(ji)) - ztrid(ji,numeqmin(ji),3)* ( isnow(ji)*t_s_b(ji,1)   & 
     684               &          + (1.0-isnow(ji))*t_i_b(ji,1) ) ) / zdiagbis(ji,numeqmin(ji))   
    744685         END DO 
    745686         ! 
    … …  
    751692         ! zerrit(ji) is a measure of error, it has to be under maxer_i_thd 
    752693         DO ji = kideb , kiut 
    753             t_su_b(ji)          =  MAX(MIN(t_su_b(ji),ztfs(ji)),190.0) 
    754             zerrit(ji)          =  ABS(t_su_b(ji)-ztsuoldit(ji))      
     694            t_su_b(ji) =  MAX(  MIN( t_su_b(ji) , ztfs(ji) ) , 190._wp  ) 
     695            zerrit(ji) =  ABS( t_su_b(ji) - ztsuoldit(ji) )      
    755696         END DO 
    756697 
    757698         DO layer  =  1, nlay_s 
    758699            DO ji = kideb , kiut 
    759                zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    760                zjj                 = ( npb(ji) - 1 ) / jpi + 1 
    761                t_s_b(ji,layer)  =  MAX(MIN(t_s_b(ji,layer),rtt),190.0) 
    762                zerrit(ji)       =  MAX(zerrit(ji),ABS(t_s_b(ji,layer) & 
    763                   -  ztstemp(ji,layer))) 
     700               ii = MOD( npb(ji) - 1, jpi ) + 1 
     701               ij = ( npb(ji) - 1 ) / jpi + 1 
     702               t_s_b(ji,layer) = MAX(  MIN( t_s_b(ji,layer), rtt ), 190._wp  ) 
     703               zerrit(ji)      = MAX(zerrit(ji),ABS(t_s_b(ji,layer) - ztstemp(ji,layer))) 
    764704            END DO 
    765705         END DO 
    … …  
    767707         DO layer  =  1, nlay_i 
    768708            DO ji = kideb , kiut 
    769                ztmelt_i         = -tmut*s_i_b(ji,layer) +rtt  
    770                t_i_b(ji,layer)  =  MAX(MIN(t_i_b(ji,layer),ztmelt_i),190.0) 
    771                zerrit(ji)       =  MAX(zerrit(ji),ABS(t_i_b(ji,layer) - ztitemp(ji,layer))) 
     709               ztmelt_i        = -tmut * s_i_b(ji,layer) + rtt  
     710               t_i_b(ji,layer) =  MAX(MIN(t_i_b(ji,layer),ztmelt_i),190.0) 
     711               zerrit(ji)      =  MAX(zerrit(ji),ABS(t_i_b(ji,layer) - ztitemp(ji,layer))) 
    772712            END DO 
    773713         END DO 
    774714 
    775715         ! Compute spatial maximum over all errors 
    776          ! note that this could be optimized substantially by iterating only 
    777          ! the non-converging points 
    778          zerritmax = 0.0 
    779          DO ji = kideb , kiut 
    780             zerritmax           =  MAX(zerritmax,zerrit(ji))    
    781          END DO 
    782          IF( lk_mpp ) CALL mpp_max(zerritmax, kcom=ncomm_ice) 
     716         ! note that this could be optimized substantially by iterating only the non-converging points 
     717         zerritmax = 0._wp 
     718         DO ji = kideb, kiut 
     719            zerritmax = MAX( zerritmax, zerrit(ji) )    
     720         END DO 
     721         IF( lk_mpp ) CALL mpp_max( zerritmax, kcom=ncomm_ice ) 
    783722 
    784723      END DO  ! End of the do while iterative procedure 
    … …  
    790729 
    791730      ! 
    792       !-------------------------------------------------------------------------- 
    793       !   11) Fluxes at the interfaces                                          | 
    794       !-------------------------------------------------------------------------- 
    795       ! 
     731      !-------------------------------------------------------------------------! 
     732      !   11) Fluxes at the interfaces                                          ! 
     733      !-------------------------------------------------------------------------! 
    796734      DO ji = kideb, kiut 
    797          ! update of latent heat fluxes 
    798          qla_ice_1d (ji) = qla_ice_1d (ji) + & 
    799             dqla_ice_1d(ji) * ( t_su_b(ji) - ztsuold(ji) ) 
    800  
    801          ! surface ice conduction flux 
    802          isnow(ji)       = int(1.0-max(0.0,sign(1.0,-ht_s_b(ji)))) 
    803          fc_su(ji)       =  - isnow(ji)*zkappa_s(ji,0)*zg1s*(t_s_b(ji,1) - & 
    804             t_su_b(ji)) & 
    805             - (1.0-isnow(ji))*zkappa_i(ji,0)*zg1* & 
    806             (t_i_b(ji,1) - t_su_b(ji)) 
    807  
    808          ! bottom ice conduction flux 
    809          fc_bo_i(ji)     =  - zkappa_i(ji,nlay_i)* & 
    810             ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 
    811  
     735         !                                ! update of latent heat fluxes 
     736         qla_ice_1d (ji) = qla_ice_1d (ji) + dqla_ice_1d(ji) * ( t_su_b(ji) - ztsuold(ji) ) 
     737         !                                ! surface ice conduction flux 
     738         isnow(ji)       = INT(  1._wp - MAX( 0._wp, SIGN( 1._wp, -ht_s_b(ji) ) )  ) 
     739         fc_su(ji)       =  -           isnow(ji)   * zkappa_s(ji,0) * zg1s * (t_s_b(ji,1) - t_su_b(ji))   & 
     740            &               - ( 1._wp - isnow(ji) ) * zkappa_i(ji,0) * zg1  * (t_i_b(ji,1) - t_su_b(ji)) 
     741         !                                ! bottom ice conduction flux 
     742         fc_bo_i(ji)     =  - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 
    812743      END DO 
    813744 
    … …  
    815746      ! Heat conservation       ! 
    816747      !-------------------------! 
    817       IF ( con_i ) THEN 
    818  
     748      IF( con_i ) THEN 
    819749         DO ji = kideb, kiut 
    820750            ! Upper snow value 
    821             fc_s(ji,0) = - isnow(ji)* & 
    822                zkappa_s(ji,0) * zg1s * ( t_s_b(ji,1) - & 
    823                t_su_b(ji) )  
     751            fc_s(ji,0) = - isnow(ji) * zkappa_s(ji,0) * zg1s * ( t_s_b(ji,1) - t_su_b(ji) )  
    824752            ! Bott. snow value 
    825             fc_s(ji,1) = - isnow(ji)* & 
    826                zkappa_s(ji,1) * ( t_i_b(ji,1) - & 
    827                t_s_b(ji,1) )  
    828          END DO 
    829  
    830          ! Upper ice layer 
    831          DO ji = kideb, kiut 
     753            fc_s(ji,1) = - isnow(ji)* zkappa_s(ji,1) * ( t_i_b(ji,1) - t_s_b(ji,1) )  
     754         END DO 
     755         DO ji = kideb, kiut         ! Upper ice layer 
    832756            fc_i(ji,0) = - isnow(ji) * &  ! interface flux if there is snow 
    833757               ( zkappa_i(ji,0)  * ( t_i_b(ji,1) - t_s_b(ji,nlay_s ) ) ) & 
    … …  
    835759               zg1 * ( t_i_b(ji,1) - t_su_b(ji) ) ) ! upper flux if not 
    836760         END DO 
    837  
    838          ! Internal ice layers 
    839          DO layer = 1, nlay_i - 1 
     761         DO layer = 1, nlay_i - 1         ! Internal ice layers 
    840762            DO ji = kideb, kiut 
    841                fc_i(ji,layer) = - zkappa_i(ji,layer) * ( t_i_b(ji,layer+1) - & 
    842                   t_i_b(ji,layer) ) 
    843                zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    844                zjj                 = ( npb(ji) - 1 ) / jpi + 1 
    845             END DO 
    846          END DO 
    847  
    848          ! Bottom ice layers 
    849          DO ji = kideb, kiut 
    850             fc_i(ji,nlay_i) = - zkappa_i(ji,nlay_i)* & 
    851                ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 
    852          END DO 
    853  
     763               fc_i(ji,layer) = - zkappa_i(ji,layer) * ( t_i_b(ji,layer+1) - t_i_b(ji,layer) ) 
     764               ii = MOD( npb(ji) - 1, jpi ) + 1 
     765               ij = ( npb(ji) - 1 ) / jpi + 1 
     766            END DO 
     767         END DO 
     768         DO ji = kideb, kiut         ! Bottom ice layers 
     769            fc_i(ji,nlay_i) = - zkappa_i(ji,nlay_i) * ( zg1*(t_bo_b(ji) - t_i_b(ji,nlay_i)) ) 
     770         END DO 
    854771      ENDIF 
    855  
     772      ! 
    856773   END SUBROUTINE lim_thd_dif 
    857774 
    858775#else 
    859    !!====================================================================== 
    860    !!                       ***  MODULE limthd_dif   *** 
    861    !!                              no sea ice model 
    862    !!====================================================================== 
     776   !!---------------------------------------------------------------------- 
     777   !!                   Dummy Module                 No LIM-3 sea-ice model 
     778   !!---------------------------------------------------------------------- 
    863779CONTAINS 
    864780   SUBROUTINE lim_thd_dif          ! Empty routine 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd_ent.F90

    r2528 r2612  
    66   !!                       after vertical growth/decay 
    77   !!====================================================================== 
     8   !! History :  LIM  ! 2003-05 (M. Vancoppenolle) Original code in 1D 
     9   !!                 ! 2005-07 (M. Vancoppenolle) 3D version  
     10   !!                 ! 2006-11 (X. Fettweis) Vectorized  
     11   !!            3.0  ! 2008-03 (M. Vancoppenolle) Energy conservation and clean code 
     12   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
     13   !!---------------------------------------------------------------------- 
    814#if defined key_lim3 
    915   !!---------------------------------------------------------------------- 
    … …  
    1319   !!---------------------------------------------------------------------- 
    1420   USE par_oce          ! ocean parameters 
    15    USE dom_oce 
    16    USE domain 
    17    USE in_out_manager 
    18    USE phycst 
    19    USE thd_ice 
    20    USE ice 
    21    USE limvar 
    22    USE par_ice 
    23    USE lib_mpp  
     21   USE dom_oce          ! domain variables 
     22   USE domain           ! 
     23   USE phycst           ! physical constants 
     24   USE ice              ! LIM variables 
     25   USE par_ice          ! LIM parameters 
     26   USE thd_ice          ! LIM thermodynamics 
     27   USE limvar           ! LIM variables 
     28   USE in_out_manager   ! I/O manager 
     29   USE wrk_nemo         ! workspace manager 
     30   USE lib_mpp          ! MPP library 
    2431 
    2532   IMPLICIT NONE 
    … …  
    2835   PUBLIC   lim_thd_ent     ! called by lim_thd 
    2936 
    30    REAL(wp)  ::           &  ! constant values 
    31       epsi20 = 1.e-20  ,  & 
    32       epsi13 = 1.e-13  ,  & 
    33       zzero  = 0.e0    ,  & 
    34       zone   = 1.e0    ,  & 
    35       epsi10 = 1.0e-10 
     37   REAL(wp) ::   epsi20 = 1e-20_wp   ! constant values 
     38   REAL(wp) ::   epsi13 = 1e-13_wp   ! 
     39   REAL(wp) ::   epsi10 = 1e-10_wp   ! 
     40   REAL(wp) ::   epsi06 = 1e-06_wp   ! 
     41   REAL(wp) ::   zzero  = 0._wp      ! 
     42   REAL(wp) ::   zone   = 1._wp      ! 
     43 
    3644   !!---------------------------------------------------------------------- 
    37    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     45   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3846   !! $Id$ 
    3947   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    4149CONTAINS 
    4250 
    43    SUBROUTINE lim_thd_ent(kideb,kiut,jl) 
     51   SUBROUTINE lim_thd_ent( kideb, kiut, jl ) 
    4452      !!------------------------------------------------------------------- 
    4553      !!               ***   ROUTINE lim_thd_ent  *** 
    … …  
    6068      !!            5) Ice salinity, recover temperature 
    6169      !! 
    62       !! ** Arguments 
    63       !! 
    64       !! ** Inputs / Outputs 
    65       !! 
    66       !! ** External 
    67       !! 
    68       !! ** References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 
    69       !! 
    70       !! ** History  : (05-2003) Martin V. UCL-Astr 
    71       !!               (07-2005) Martin for 3d adapatation 
    72       !!               (11-2006) Vectorized by Xavier Fettweis (ASTR) 
    73       !!               (03-2008) Energy conservation and clean code 
    74       !! * Arguments 
    75  
    76       INTEGER , INTENT(IN)::  & 
    77          kideb          ,   &  ! start point on which the the computation is applied 
    78          kiut           ,   &  ! end point on which the the computation is applied 
    79          jl                    ! thickness category number 
    80  
    81       INTEGER ::            & 
    82          ji,jk          ,   &  !  dummy loop indices 
    83          zji, zjj       ,   &  !  dummy indices 
     70      !! References : Bitz & Lipscomb, JGR 99; Vancoppenolle et al., GRL, 2005 
     71      !!------------------------------------------------------------------- 
     72      INTEGER , INTENT(in) ::   kideb, kiut   ! Start/End point on which the  the computation is applied 
     73      INTEGER , INTENT(in) ::   jl            ! Thickness cateogry number 
     74 
     75      INTEGER ::   ji,jk   !  dummy loop indices 
     76      INTEGER ::   zji, zjj       ,   &  !  dummy indices 
    8477         ntop0          ,   &  !  old layer top index 
    8578         nbot1          ,   &  !  new layer bottom index 
    … …  
    9083         layer0, layer1        !  old/new layer indexes 
    9184 
    92       INTEGER, DIMENSION(jpij) :: & 
    93          snswi          ,   &  !  snow switch 
    94          nbot0          ,   &  !  old layer bottom index 
    95          icsuind        ,   &  !  ice surface index 
    96          icsuswi        ,   &  !  ice surface switch 
    97          icboind        ,   &  !  ice bottom index 
    98          icboswi        ,   &  !  ice bottom switch 
    99          snicind        ,   &  !  snow ice index 
    100          snicswi        ,   &  !  snow ice switch 
    101          snind                 !  snow index 
    10285 
    10386      REAL(wp) :: & 
    104          zeps, zeps6    ,   &  ! numerical constant very small 
    10587         ztmelts        ,   &  ! ice melting point 
    10688         zqsnic         ,   &  ! enthalpy of snow ice layer 
    … …  
    11597         zdiscrim              !: dummy factor 
    11698 
    117       REAL(wp), DIMENSION(jpij) :: &   
    118          zh_i           ,   &  ! thickness of an ice layer 
    119          zh_s           ,   &  ! thickness of a snow layer 
    120          zqsnow         ,   &  ! enthalpy of the snow put in snow ice    
    121          zdeltah               ! temporary variable 
    122  
    123       REAL(wp), DIMENSION(jpij,0:jkmax+3) :: & 
    124          zm0            ,   &  !  old layer-system vertical cotes 
    125          qm0            ,   &  !  old layer-system heat content 
    126          z_s            ,   &  !  new snow system vertical cotes 
    127          z_i            ,   &  !  new ice system vertical cotes 
    128          zthick0               !  old ice thickness 
    129  
    130       REAL(wp), DIMENSION(jpij,0:jkmax+3) :: & 
    131          zhl0                  ! old and new layer thicknesses 
    132  
    133       REAL(wp), DIMENSION(0:jkmax+3,0:jkmax+3) :: & 
    134          zrl01 
    135  
    136       ! Energy conservation 
    137       REAL(wp), DIMENSION(jpij) :: & 
    138          zqti_in, zqts_in,         & 
    139          zqti_fin, zqts_fin 
    140  
    141       !------------------------------------------------------------------------------| 
    142  
    143       zeps   = 1.0d-20 
    144       zeps6  = 1.0d-06 
    145       zthick0(:,:) = 0.0 
    146       zm0(:,:)     = 0.0 
    147       qm0(:,:)     = 0.0 
    148       zrl01(:,:)   = 0.0 
    149       zhl0(:,:)    = 0.0 
    150       z_i(:,:)     = 0.0 
    151       z_s(:,:)     = 0.0 
     99      INTEGER, DIMENSION(jpij) :: & 
     100         snswi          ,   &  !  snow switch 
     101         nbot0          ,   &  !  old layer bottom index 
     102         icsuind        ,   &  !  ice surface index 
     103         icsuswi        ,   &  !  ice surface switch 
     104         icboind        ,   &  !  ice bottom index 
     105         icboswi        ,   &  !  ice bottom switch 
     106         snicind        ,   &  !  snow ice index 
     107         snicswi        ,   &  !  snow ice switch 
     108         snind                 !  snow index 
     109      ! 
     110      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   zm0       !  old layer-system vertical cotes 
     111      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   qm0       !  old layer-system heat content 
     112      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   z_s       !  new snow system vertical cotes 
     113      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   z_i       !  new ice system vertical cotes 
     114      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   zthick0   !  old ice thickness 
     115      REAL(wp), DIMENSION(jpij,0:jkmax+3) ::   zhl0      ! old and new layer thicknesses 
     116      ! 
     117      REAL(wp), DIMENSION(0:jkmax+3,0:jkmax+3) ::   zrl01 
     118      ! 
     119      REAL(wp), POINTER, DIMENSION(:) ::   zh_i, zqsnow , zqti_in, zqti_fin 
     120      REAL(wp), POINTER, DIMENSION(:) ::   zh_s, zdeltah, zqts_in, zqts_fin 
     121      !!------------------------------------------------------------------- 
     122 
     123      IF( .NOT. wrk_use(1, 1,2,3,4,5,6,7,8) ) THEN 
     124         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN 
     125      END IF 
     126 
     127      ! Set-up pointers to sub-arrays of workspace arrays 
     128      zh_i      =>  wrk_1d_1 (1:jpij)   ! thickness of an ice layer 
     129      zh_s      =>  wrk_1d_2 (1:jpij)   ! thickness of a snow layer 
     130      zqsnow    =>  wrk_1d_3 (1:jpij)   ! enthalpy of the snow put in snow ice 
     131      zdeltah   =>  wrk_1d_4 (1:jpij)   ! temporary variable 
     132      zqti_in   =>  wrk_1d_5 (1:jpij)   ! Energy conservation 
     133      zqts_in   =>  wrk_1d_6 (1:jpij)   !    -         - 
     134      zqti_fin  =>  wrk_1d_7 (1:jpij)   !    -         - 
     135      zqts_fin  =>  wrk_1d_8 (1:jpij)   !    -         - 
     136 
     137      zthick0(:,:) = 0._wp 
     138      zm0    (:,:) = 0._wp 
     139      qm0    (:,:) = 0._wp 
     140      zrl01  (:,:) = 0._wp 
     141      zhl0   (:,:) = 0._wp 
     142      z_i    (:,:) = 0._wp 
     143      z_s    (:,:) = 0._wp 
    152144 
    153145      ! 
    … …  
    155147      !  1) Grid                                                                     | 
    156148      !------------------------------------------------------------------------------| 
    157       ! 
    158       nlays0        = nlay_s 
    159       nlayi0        = nlay_i 
    160  
    161       DO ji = kideb, kiut 
    162          zh_i(ji)   = old_ht_i_b(ji) / nlay_i  
    163          zh_s(ji)   = old_ht_s_b(ji) / nlay_s 
    164       ENDDO 
     149      nlays0 = nlay_s 
     150      nlayi0 = nlay_i 
     151 
     152      DO ji = kideb, kiut 
     153         zh_i(ji) = old_ht_i_b(ji) / nlay_i  
     154         zh_s(ji) = old_ht_s_b(ji) / nlay_s 
     155      END DO 
    165156 
    166157      ! 
    … …  
    168159      !  2) Switches                                                                 | 
    169160      !------------------------------------------------------------------------------| 
    170       ! 
    171161      ! 2.1 snind(ji), snswi(ji) 
    172162      ! snow surface behaviour : computation of snind(ji)-snswi(ji) 
    … …  
    176166      !   2 if 2nd layer is melting ... 
    177167      DO ji = kideb, kiut 
    178          snind(ji)    = 0 
    179          zdeltah(ji)   = 0.0 
     168         snind  (ji) = 0 
     169         zdeltah(ji) = 0._wp 
    180170      ENDDO !ji 
    181171 
    182172      DO jk = 1, nlays0 
    183173         DO ji = kideb, kiut 
    184             snind(ji)  = jk        *      INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-zeps))) & 
    185                + snind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-zeps)))) 
     174            snind(ji)  = jk        *      INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-epsi20))) & 
     175               + snind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_s_tot(ji)-zdeltah(ji)-epsi20)))) 
    186176            zdeltah(ji)= zdeltah(ji) + zh_s(ji) 
    187177         END DO ! ji 
    188       ENDDO ! jk 
     178      END DO ! jk 
    189179 
    190180      ! snswi(ji) : switch which value equals 1 if snow melts 
    191181      !              0 if not 
    192182      DO ji = kideb, kiut 
    193          snswi(ji)     = MAX(0,INT(-dh_s_tot(ji)/MAX(zeps,ABS(dh_s_tot(ji))))) 
    194       ENDDO ! ji 
     183         snswi(ji)     = MAX(0,INT(-dh_s_tot(ji)/MAX(epsi20,ABS(dh_s_tot(ji))))) 
     184      END DO ! ji 
    195185 
    196186      ! 2.2 icsuind(ji), icsuswi(ji) 
    … …  
    201191      !     2 if 2nd layer is reached by melt ... 
    202192      DO ji = kideb, kiut 
    203          icsuind(ji)   = 0 
    204          zdeltah(ji)   = 0.0 
    205       ENDDO !ji 
     193         icsuind(ji) = 0 
     194         zdeltah(ji) = 0._wp 
     195      END DO !ji 
    206196      DO jk = 1, nlayi0 
    207197         DO ji = kideb, kiut 
    208             icsuind(ji) = jk          *      INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-zeps))) & 
    209                + icsuind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-zeps)))) 
     198            icsuind(ji) = jk          *      INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-epsi20))) & 
     199               + icsuind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_surf(ji)-zdeltah(ji)-epsi20)))) 
    210200            zdeltah(ji) = zdeltah(ji) + zh_i(ji) 
    211201         END DO ! ji 
    … …  
    216206      !     0 if not 
    217207      DO ji = kideb, kiut 
    218          icsuswi(ji)  = MAX(0,INT(-dh_i_surf(ji)/MAX(zeps , ABS(dh_i_surf(ji)) ) ) ) 
     208         icsuswi(ji)  = MAX(0,INT(-dh_i_surf(ji)/MAX(epsi20 , ABS(dh_i_surf(ji)) ) ) ) 
    219209      ENDDO 
    220210 
    … …  
    227217      !            N+1 if all layers melt and that snow transforms into ice 
    228218      DO ji = kideb, kiut  
    229          icboind(ji)   = 0 
    230          zdeltah(ji)   = 0.0 
    231       ENDDO 
     219         icboind(ji) = 0 
     220         zdeltah(ji) = 0._wp 
     221      END DO 
    232222      DO jk = nlayi0, 1, -1 
    233223         DO ji = kideb, kiut 
    234             icboind(ji) = (nlayi0+1-jk) & 
    235                *      INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-zeps))) & 
    236                + icboind(ji) & 
    237                * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-zeps))))  
     224            icboind(ji) = (nlayi0+1-jk) *      INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-epsi20))) & 
     225               &          + icboind(ji) * (1 - INT(MAX(0.0,SIGN(1.0,-dh_i_bott(ji)-zdeltah(ji)-epsi20))))  
    238226            zdeltah(ji) = zdeltah(ji) + zh_i(ji) 
    239227         END DO 
    240       ENDDO 
     228      END DO 
    241229 
    242230      DO ji = kideb, kiut 
    243231         ! case of total ablation with remaining snow 
    244          IF ( ( ht_i_b(ji) .GT. zeps ) .AND. & 
    245             ( ht_i_b(ji) - dh_snowice(ji) .LT. zeps ) ) icboind(ji) = nlay_i + 1 
     232         IF ( ( ht_i_b(ji) .GT. epsi20 ) .AND. & 
     233            ( ht_i_b(ji) - dh_snowice(ji) .LT. epsi20 ) ) icboind(ji) = nlay_i + 1 
    246234      END DO 
    247235 
    … …  
    250238      !     0 if ablation is on the way 
    251239      DO ji = kideb, kiut  
    252          icboswi(ji)     = MAX(0,INT(dh_i_bott(ji) / MAX(zeps,ABS(dh_i_bott(ji))))) 
    253       ENDDO 
     240         icboswi(ji) = MAX(0,INT(dh_i_bott(ji) / MAX(epsi20,ABS(dh_i_bott(ji))))) 
     241      END DO 
    254242 
    255243      ! 2.4 snicind(ji), snicswi(ji) 
    … …  
    260248      !     2 if penultiem layer ... 
    261249      DO ji = kideb, kiut 
    262          snicind(ji)   = 0 
    263          zdeltah(ji)   = 0.0 
    264       ENDDO 
     250         snicind(ji) = 0 
     251         zdeltah(ji) = 0._wp 
     252      END DO 
    265253      DO jk = nlays0, 1, -1 
    266254         DO ji = kideb, kiut 
    267255            snicind(ji) = (nlays0+1-jk) & 
    268                *      INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-zeps))) & 
    269                + snicind(ji) & 
    270                * (1 - INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-zeps)))) 
     256               *      INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-epsi20))) + snicind(ji)   & 
     257               * (1 - INT(MAX(0.0,SIGN(1.0,dh_snowice(ji)-zdeltah(ji)-epsi20)))) 
    271258            zdeltah(ji) = zdeltah(ji) + zh_s(ji) 
    272259         END DO 
    273       ENDDO 
     260      END DO 
    274261 
    275262      ! snicswi(ji) : switch which equals  
    … …  
    277264      !     0 if not 
    278265      DO ji = kideb, kiut 
    279          snicswi(ji)   = MAX(0,INT(dh_snowice(ji)/MAX(zeps,ABS(dh_snowice(ji))))) 
     266         snicswi(ji)   = MAX(0,INT(dh_snowice(ji)/MAX(epsi20,ABS(dh_snowice(ji))))) 
    280267      ENDDO 
    281268 
    … …  
    294281      ! indexes of the vectors 
    295282      !------------------------ 
    296       ntop0                =  1 
    297       maxnbot0             =  0 
    298  
    299       DO ji = kideb, kiut 
    300          nbot0(ji)          =  nlays0  + 1 - snind(ji) + ( 1. - snicind(ji) ) * & 
    301             snicswi(ji) 
     283      ntop0    =  1 
     284      maxnbot0 =  0 
     285 
     286      DO ji = kideb, kiut 
     287         nbot0(ji) =  nlays0  + 1 - snind(ji) + ( 1. - snicind(ji) ) * snicswi(ji) 
    302288         ! cotes of the top of the layers 
    303          zm0(ji,0)          =  0.0 
    304          maxnbot0           =  MAX ( maxnbot0 , nbot0(ji) ) 
    305       ENDDO 
    306       IF( lk_mpp ) CALL mpp_max( maxnbot0, kcom=ncomm_ice ) 
     289         zm0(ji,0) =  0._wp 
     290         maxnbot0 =  MAX ( maxnbot0 , nbot0(ji) ) 
     291      END DO 
     292      IF( lk_mpp )   CALL mpp_max( maxnbot0, kcom=ncomm_ice ) 
    307293 
    308294      DO jk = 1, maxnbot0 
    309295         DO ji = kideb, kiut 
    310296            !change 
    311             limsum      = ( 1 - snswi(ji) ) * ( jk - 1 ) +                      & 
    312                snswi(ji) * ( jk + snind(ji) - 1 ) 
     297            limsum = ( 1 - snswi(ji) ) * ( jk - 1 ) + snswi(ji) * ( jk + snind(ji) - 1 ) 
     298            limsum = MIN( limsum , nlay_s ) 
     299            zm0(ji,jk) =  dh_s_tot(ji) + zh_s(ji) * limsum 
     300         END DO 
     301      END DO 
     302 
     303      DO ji = kideb, kiut 
     304         zm0(ji,nbot0(ji)) =  dh_s_tot(ji) - snicswi(ji) * dh_snowice(ji) + zh_s(ji) * nlays0 
     305         zm0(ji,1)         =  dh_s_tot(ji) * (1 -snswi(ji) ) + snswi(ji) * zm0(ji,1) 
     306      END DO 
     307 
     308      DO jk = ntop0, maxnbot0 
     309         DO ji = kideb, kiut 
     310            zthick0(ji,jk)  =  zm0(ji,jk) - zm0(ji,jk-1)            ! layer thickness 
     311         END DO 
     312      END DO 
     313 
     314      zqts_in(:) = 0._wp 
     315 
     316      DO ji = kideb, kiut         ! layer heat content 
     317         qm0    (ji,1) =  rhosn * (  cpic * ( rtt - ( 1. - snswi(ji) ) * tatm_ice_1d(ji)        & 
     318            &                                            - snswi(ji)   * t_s_b      (ji,1)  )   & 
     319            &                      + lfus  ) * zthick0(ji,1) 
     320         zqts_in(ji)   =  zqts_in(ji) + qm0(ji,1)  
     321      END DO 
     322 
     323      DO jk = 2, maxnbot0 
     324         DO ji = kideb, kiut 
     325            limsum      = ( 1 - snswi(ji) ) * ( jk - 1 ) + snswi(ji) * ( jk + snind(ji) - 1 ) 
    313326            limsum      = MIN( limsum , nlay_s ) 
    314             zm0(ji,jk)  =  dh_s_tot(ji) + zh_s(ji) * limsum 
    315          END DO 
    316       ENDDO 
    317  
    318       DO ji = kideb, kiut 
    319          zm0(ji,nbot0(ji)) =  dh_s_tot(ji) - snicswi(ji) * dh_snowice(ji) + & 
    320             zh_s(ji) * nlays0 
    321          zm0(ji,1)         =  dh_s_tot(ji) * (1 -snswi(ji) ) +              & 
    322             snswi(ji) * zm0(ji,1) 
    323       ENDDO 
    324  
    325       DO jk = ntop0, maxnbot0 
    326          DO ji = kideb, kiut 
    327             ! layer thickness 
    328             zthick0(ji,jk)  =  zm0(ji,jk) - zm0(ji,jk-1) 
    329          END DO 
    330       ENDDO 
    331  
    332       zqts_in(:) = 0.0 
    333  
    334       DO ji = kideb, kiut 
    335          ! layer heat content 
    336          qm0(ji,1)   =  rhosn * ( cpic * ( rtt - ( 1. - snswi(ji) ) * ( tatm_ice_1d(ji) ) & 
    337             - snswi(ji) * t_s_b(ji,1) )         & 
    338             + lfus ) * zthick0(ji,1) 
    339          zqts_in(ji) =  zqts_in(ji) + qm0(ji,1)  
    340       ENDDO 
    341  
    342       DO jk = 2, maxnbot0 
    343          DO ji = kideb, kiut 
    344             limsum      = ( 1 - snswi(ji) ) * ( jk - 1 ) +                      & 
    345                snswi(ji) * ( jk + snind(ji) - 1 ) 
    346             limsum      = MIN( limsum , nlay_s ) 
    347             qm0(ji,jk)  = rhosn * ( cpic * ( rtt - t_s_b(ji,limsum) ) + lfus )  & 
    348                * zthick0(ji,jk) 
    349             zswitch = 1.0 - MAX (0.0, SIGN ( 1.0, zeps - ht_s_b(ji) ) ) 
     327            qm0(ji,jk)  = rhosn * ( cpic * ( rtt - t_s_b(ji,limsum) ) + lfus ) * zthick0(ji,jk) 
     328            zswitch = 1.0 - MAX (0.0, SIGN ( 1.0, epsi20 - ht_s_b(ji) ) ) 
    350329            zqts_in(ji) = zqts_in(ji) + ( 1. - snswi(ji) ) * qm0(ji,jk) * zswitch 
    351330         END DO ! jk 
    352       ENDDO ! ji 
     331      END DO ! ji 
    353332 
    354333      !------------------------------------------------ 
    … …  
    357336      ! zqsnow, enthalpy of the flooded snow 
    358337      DO ji = kideb, kiut 
    359          zqsnow(ji)     =  rhosn*lfus 
    360          zdeltah(ji)    =  0.0 
    361       ENDDO 
     338         zqsnow (ji) =  rhosn * lfus 
     339         zdeltah(ji) =  0._wp 
     340      END DO 
    362341 
    363342      DO jk =  nlays0, 1, -1 
    364343         DO ji = kideb, kiut 
    365             zhsnow      =  MAX(0.0,dh_snowice(ji)-zdeltah(ji)) 
    366             zqsnow(ji)  =  zqsnow(ji) + & 
    367                rhosn*cpic*(rtt-t_s_b(ji,jk)) 
     344            zhsnow =  MAX( 0._wp , dh_snowice(ji)-zdeltah(ji) ) 
     345            zqsnow (ji) =  zqsnow (ji) + rhosn*cpic*(rtt-t_s_b(ji,jk)) 
    368346            zdeltah(ji) =  zdeltah(ji) + zh_s(ji) 
    369347         END DO 
    370       ENDDO 
     348      END DO 
    371349 
    372350      DO ji = kideb, kiut 
    … …  
    381359      ! Vector index    
    382360      !-------------- 
    383       ntop1    =  1 
    384       nbot1    =  nlay_s 
     361      ntop1 =  1 
     362      nbot1 =  nlay_s 
    385363 
    386364      !------------------- 
    … …  
    389367      DO ji = kideb, kiut 
    390368         zh_s(ji)  = ht_s_b(ji) / nlay_s 
    391          z_s(ji,0) =  0.0 
     369         z_s(ji,0) =  0._wp 
    392370      ENDDO 
    393371 
    … …  
    396374            z_s(ji,jk) =  zh_s(ji) * jk 
    397375         END DO 
    398       ENDDO 
     376      END DO 
    399377 
    400378      !----------------- 
    … …  
    405383            zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1) 
    406384         END DO 
    407       ENDDO 
     385      END DO 
    408386 
    409387      DO layer1 = ntop1, nbot1 
    410388         DO ji = kideb, kiut 
    411             q_s_b(ji,layer1)= 0.0 
    412          END DO 
    413       ENDDO 
     389            q_s_b(ji,layer1) = 0._wp 
     390         END DO 
     391      END DO 
    414392 
    415393      !---------------- 
    … …  
    419397         DO layer1 = ntop1, nbot1 
    420398            DO ji = kideb, kiut 
    421                zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_s(ji,layer1)) & 
    422                   - MAX(zm0(ji,layer0-1), z_s(ji,layer1-1)))/MAX(zhl0(ji,layer0),epsi10))  
    423                q_s_b(ji,layer1) = q_s_b(ji,layer1) + zrl01(layer1,layer0)*qm0(ji,layer0) & 
    424                   * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+zeps)) 
     399               zrl01(layer1,layer0) = MAX(0.0,( MIN(zm0(ji,layer0),z_s(ji,layer1))   & 
     400                  &                 - MAX(zm0(ji,layer0-1), z_s(ji,layer1-1))) / MAX(zhl0(ji,layer0),epsi10))  
     401               q_s_b(ji,layer1) = q_s_b(ji,layer1) + zrl01(layer1,layer0)*qm0(ji,layer0)   & 
     402                  &                                * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+epsi20)) 
    425403            END DO 
    426404         END DO 
    427       ENDDO 
     405      END DO 
    428406 
    429407      ! Heat conservation 
    430       zqts_fin(:) = 0.0 
     408      zqts_fin(:) = 0._wp 
    431409      DO jk = 1, nlay_s 
    432410         DO ji = kideb, kiut 
    … …  
    458436      DO jk = 1, nlay_s 
    459437         DO ji = kideb, kiut 
    460             q_s_b(ji,jk) = q_s_b(ji,jk) / MAX( zh_s(ji) , zeps ) 
     438            q_s_b(ji,jk) = q_s_b(ji,jk) / MAX( zh_s(ji) , epsi20 ) 
    461439         END DO !ji 
    462       ENDDO !jk   
     440      END DO !jk   
    463441 
    464442      !--------------------- 
    … …  
    469447      DO jk = 1, nlay_s 
    470448         DO ji = kideb, kiut 
    471             zswitch = MAX ( 0.0 , SIGN ( 1.0, zeps - ht_s_b(ji) ) ) 
    472             t_s_b(ji,jk) = rtt                                                  & 
    473                + ( 1.0 - zswitch ) *                                  & 
    474                ( - zfac1 * q_s_b(ji,jk) + zfac2 ) 
    475          END DO 
    476       ENDDO 
     449            zswitch = MAX ( 0.0 , SIGN ( 1.0, epsi20 - ht_s_b(ji) ) ) 
     450            t_s_b(ji,jk) = rtt + ( 1.0 - zswitch ) * ( - zfac1 * q_s_b(ji,jk) + zfac2 ) 
     451         END DO 
     452      END DO 
    477453      ! 
    478454      !------------------------------------------------------------------------------| 
    … …  
    487463      ! Vector indexes 
    488464      !---------------- 
    489       ntop0          =  1 
    490       maxnbot0       =  0 
     465      ntop0    =  1 
     466      maxnbot0 =  0 
    491467 
    492468      DO ji = kideb, kiut 
    493469         ! reference number of the bottommost layer 
    494          nbot0(ji)    =  MAX( 1 ,  MIN( nlayi0 + ( 1 - icboind(ji) ) +        & 
    495             ( 1 - icsuind(ji) ) * icsuswi(ji) + snicswi(ji) ,    & 
    496             nlay_i + 2 ) ) 
     470         nbot0(ji) =  MAX( 1 ,  MIN( nlayi0 + ( 1 - icboind(ji) ) +        & 
     471            &                           ( 1 - icsuind(ji) ) * icsuswi(ji) + snicswi(ji) , nlay_i + 2 ) ) 
    497472         ! maximum reference number of the bottommost layer over all domain 
    498          maxnbot0     =  MAX( maxnbot0 , nbot0(ji) ) 
    499       ENDDO 
     473         maxnbot0 =  MAX( maxnbot0 , nbot0(ji) ) 
     474      END DO 
    500475 
    501476      !------------------------- 
    502477      ! Cotes of old ice layers 
    503478      !------------------------- 
    504       zm0(:,0)    =  0.0 
     479      zm0(:,0) =  0.-wp 
    505480 
    506481      DO jk = 1, maxnbot0 
    … …  
    514489               +  limsum * zh_i(ji) 
    515490         END DO 
    516       ENDDO 
     491      END DO 
    517492 
    518493      DO ji = kideb, kiut 
    … …  
    520495            +  zh_i(ji) * nlayi0 
    521496         zm0(ji,1)         =  snicswi(ji)*dh_snowice(ji) + (1-snicswi(ji))*zm0(ji,1) 
    522       ENDDO 
     497      END DO 
    523498 
    524499      !----------------------------- 
    … …  
    529504            zthick0(ji,jk) =  zm0(ji,jk) - zm0(ji,jk-1) 
    530505         END DO 
    531       ENDDO 
     506      END DO 
    532507 
    533508      !--------------------------- 
    … …  
    543518            ztmelts = -tmut * s_i_b(ji,limsum) + rtt 
    544519            qm0(ji,jk) = rhoic * ( cpic * (ztmelts-t_i_b(ji,limsum)) + lfus * ( 1.0-(ztmelts-rtt)/ & 
    545                MIN((t_i_b(ji,limsum)-rtt),-zeps) ) - rcp*(ztmelts-rtt) ) & 
     520               MIN((t_i_b(ji,limsum)-rtt),-epsi20) ) - rcp*(ztmelts-rtt) ) & 
    546521               * zthick0(ji,jk) 
    547522         END DO 
    548       ENDDO 
     523      END DO 
    549524 
    550525      !---------------------------- 
    … …  
    552527      !---------------------------- 
    553528      DO ji = kideb, kiut         
    554          ztmelts    = ( 1.0 - icboswi(ji) ) * (-tmut * s_i_b(ji,nlayi0)) &   ! case of melting ice 
    555             +      icboswi(ji)      * (-tmut * s_i_new(ji))      &   ! case of forming ice 
    556             + rtt                        ! this temperature is in Celsius 
     529         ztmelts    = ( 1.0 - icboswi(ji) ) * (-tmut * s_i_b  (ji,nlayi0) )  &   ! case of melting ice 
     530            &       +         icboswi(ji)   * (-tmut * s_i_new(ji)        )   &   ! case of forming ice 
     531            &       + rtt                                                         ! in Kelvin 
    557532 
    558533         ! bottom formation temperature 
    559534         ztform = t_i_b(ji,nlay_i) 
    560535         IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) ztform = t_bo_b(ji) 
    561          qm0(ji,nbot0(ji)) = ( 1.0 - icboswi(ji) )*qm0(ji,nbot0(ji)) &   ! case of melting ice 
    562             + icboswi(ji) *                                  &   ! case of forming ice 
    563             rhoic*( cpic*(ztmelts-ztform)                  & 
    564             + lfus *( 1.0-(ztmelts-rtt)/             & 
    565             MIN ( (ztform-rtt) , - epsi10 ) )      &  
    566             - rcp*(ztmelts-rtt) )                    & 
    567             *zthick0(ji,nbot0(ji)) 
    568       ENDDO 
     536         qm0(ji,nbot0(ji)) = ( 1.0 - icboswi(ji) )*qm0(ji,nbot0(ji))             &   ! case of melting ice 
     537            &              + icboswi(ji) * rhoic * ( cpic*(ztmelts-ztform)       &   ! case of forming ice 
     538            + lfus *( 1.0-(ztmelts-rtt) / MIN ( (ztform-rtt) , - epsi10 ) )      &  
     539            - rcp*(ztmelts-rtt) ) * zthick0(ji,nbot0(ji)  ) 
     540      END DO 
    569541 
    570542      !----------------------------- 
    … …  
    585557         qm0(ji,1)      =  snicswi(ji) * zqsnic + ( 1 - snicswi(ji) ) * qm0(ji,1) 
    586558 
    587       ENDDO ! ji 
     559      END DO ! ji 
    588560 
    589561      DO jk = ntop0, maxnbot0 
    590562         DO ji = kideb, kiut 
    591563            ! Heat conservation 
    592             zqti_in(ji) = zqti_in(ji) + qm0(ji,jk) & 
    593                * MAX( 0.0 , SIGN(1.0,ht_i_b(ji)-zeps6+zeps) ) & 
    594                * MAX( 0.0 , SIGN( 1. , nbot0(ji) - jk + zeps ) ) 
    595          END DO 
    596       ENDDO 
     564            zqti_in(ji) = zqti_in(ji) + qm0(ji,jk) * MAX( 0.0 , SIGN(1.0,ht_i_b(ji)-epsi06+epsi20) ) & 
     565               &                                   * MAX( 0.0 , SIGN( 1. , nbot0(ji) - jk + epsi20 ) ) 
     566         END DO 
     567      END DO 
    597568 
    598569      !------------- 
    … …  
    603574      ! Vectors index 
    604575      !--------------- 
    605  
    606       ntop1    =  1  
    607       nbot1    =  nlay_i 
     576      ntop1 =  1  
     577      nbot1 =  nlay_i 
    608578 
    609579      !------------------ 
    … …  
    611581      !------------------ 
    612582      DO ji = kideb, kiut 
    613          zh_i(ji)      = ht_i_b(ji) / nlay_i 
     583         zh_i(ji) = ht_i_b(ji) / nlay_i 
    614584      ENDDO 
    615585 
    … …  
    617587      ! Layer cotes       
    618588      !------------- 
    619       z_i(:,0) =  0.0 
     589      z_i(:,0) =  0._wp 
    620590      DO jk = 1, nlay_i 
    621591         DO ji = kideb, kiut 
    622592            z_i(ji,jk) =  zh_i(ji) * jk 
    623593         END DO 
    624       ENDDO 
     594      END DO 
    625595 
    626596      !--thicknesses of the layers 
    627597      DO layer0 = ntop0, maxnbot0 
    628598         DO ji = kideb, kiut 
    629             zhl0(ji,layer0)   =  zm0(ji,layer0) - zm0(ji,layer0-1) !thicknesses of the layers 
    630          END DO 
    631       ENDDO 
     599            zhl0(ji,layer0) = zm0(ji,layer0) - zm0(ji,layer0-1)   ! thicknesses of the layers 
     600         END DO 
     601      END DO 
    632602 
    633603      !------------------------ 
    634604      ! Weights for relayering 
    635605      !------------------------ 
    636  
    637       q_i_b(:,:) = 0.0 
     606      q_i_b(:,:) = 0._wp 
    638607      DO layer0 = ntop0, maxnbot0 
    639608         DO layer1 = ntop1, nbot1 
    … …  
    643612               q_i_b(ji,layer1) = q_i_b(ji,layer1) &  
    644613                  + zrl01(layer1,layer0)*qm0(ji,layer0) & 
    645                   * MAX(0.0,SIGN(1.0,ht_i_b(ji)-zeps6+zeps)) & 
    646                   * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+zeps)) 
     614                  * MAX(0.0,SIGN(1.0,ht_i_b(ji)-epsi06+epsi20)) & 
     615                  * MAX(0.0,SIGN(1.0,nbot0(ji)-layer0+epsi20)) 
    647616            END DO 
    648617         END DO 
    649       ENDDO 
     618      END DO 
    650619 
    651620      !------------------------- 
    652621      ! Heat conservation check 
    653622      !------------------------- 
    654       zqti_fin(:) = 0.0 
     623      zqti_fin(:) = 0._wp 
    655624      DO jk = 1, nlay_i 
    656625         DO ji = kideb, kiut 
    … …  
    663632            zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    664633            zjj                 = ( npb(ji) - 1 ) / jpi + 1 
    665             WRITE(numout,*) ' violation of heat conservation : ',             & 
    666                ABS ( zqti_in(ji) - zqti_fin(ji) ) / rdt_ice 
     634            WRITE(numout,*) ' violation of heat conservation : ', ABS ( zqti_in(ji) - zqti_fin(ji) ) / rdt_ice 
    667635            WRITE(numout,*) ' ji, jj   : ', zji, zjj 
    668636            WRITE(numout,*) ' ht_i_b   : ', ht_i_b(ji) 
    … …  
    683651      DO jk = 1, nlay_i 
    684652         DO ji = kideb, kiut 
    685             q_i_b(ji,jk) = q_i_b(ji,jk) / MAX( zh_i(ji) , zeps ) 
     653            q_i_b(ji,jk) = q_i_b(ji,jk) / MAX( zh_i(ji) , epsi20 ) 
    686654         END DO !ji 
    687       ENDDO !jk   
     655      END DO !jk   
    688656 
    689657      ! Heat conservation 
    … …  
    702670      ! Update salinity (basal entrapment, snow ice formation) 
    703671      DO ji = kideb, kiut 
    704          sm_i_b(ji) = sm_i_b(ji)                                & 
    705             + dsm_i_se_1d(ji) + dsm_i_si_1d(ji) 
     672         sm_i_b(ji) = sm_i_b(ji) + dsm_i_se_1d(ji) + dsm_i_si_1d(ji) 
    706673      END DO !ji 
    707674 
    708675      ! Recover temperature 
    709676      DO jk = 1, nlay_i 
    710  
    711          DO ji = kideb, kiut 
    712  
     677         DO ji = kideb, kiut 
    713678            ztmelts    =  -tmut*s_i_b(ji,jk) + rtt 
    714679            !Conversion q(S,T) -> T (second order equation) 
    715680            zaaa         =  cpic 
    716             zbbb         =  ( rcp - cpic ) * ( ztmelts - rtt ) + & 
    717                q_i_b(ji,jk) / rhoic - lfus 
     681            zbbb         =  ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_b(ji,jk) / rhoic - lfus 
    718682            zccc         =  lfus * ( ztmelts - rtt ) 
    719683            zdiscrim     =  SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 
    720             t_i_b(ji,jk) =  rtt - ( zbbb + zdiscrim ) / &  
    721                ( 2.0 *zaaa ) 
     684            t_i_b(ji,jk) =  rtt - ( zbbb + zdiscrim ) / ( 2.0 *zaaa ) 
    722685         END DO !ji 
    723686 
    724687      END DO !jk 
    725  
     688      ! 
     689      IF( .NOT. wrk_release(1, 1,2,3,4,5,6,7,8) )   CALL ctl_stop( 'lim_thd_ent : failed to release workspace arrays.' ) 
     690      ! 
    726691   END SUBROUTINE lim_thd_ent 
    727692 
    728693#else 
    729    !!====================================================================== 
    730    !!                       ***  MODULE limthd_ent   *** 
    731    !!                             no sea ice model 
    732    !!====================================================================== 
     694   !!---------------------------------------------------------------------- 
     695   !!   Default option                               NO  LIM3 sea-ice model 
     696   !!---------------------------------------------------------------------- 
    733697CONTAINS 
    734698   SUBROUTINE lim_thd_ent          ! Empty routine 
    735699   END SUBROUTINE lim_thd_ent 
    736700#endif 
     701 
     702   !!====================================================================== 
    737703END MODULE limthd_ent 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90

    r2528 r2612  
    44   !!                lateral thermodynamic growth of the ice  
    55   !!====================================================================== 
     6   !! History :  LIM  ! 2005-12 (M. Vancoppenolle)  Original code 
     7   !!             -   ! 2006-01 (M. Vancoppenolle)  add ITD 
     8   !!            3.0  ! 2007-07 (M. Vancoppenolle)  Mass and energy conservation tested 
     9   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
     10   !!---------------------------------------------------------------------- 
    611#if defined key_lim3 
    712   !!---------------------------------------------------------------------- 
    … …  
    1116   !!---------------------------------------------------------------------- 
    1217   USE par_oce          ! ocean parameters 
    13    USE dom_oce 
    14    USE in_out_manager 
    15    USE phycst 
    16    USE sbc_oce         ! Surface boundary condition: ocean fields 
    17    USE sbc_ice         ! Surface boundary condition: ice fields 
    18    USE thd_ice 
    19    USE dom_ice 
    20    USE par_ice 
    21    USE ice 
    22    USE limtab 
    23    USE limcons 
     18   USE dom_oce          ! domain variables 
     19   USE phycst           ! physical constants 
     20   USE sbc_oce          ! Surface boundary condition: ocean fields 
     21   USE sbc_ice          ! Surface boundary condition: ice fields 
     22   USE thd_ice          ! LIM thermodynamics 
     23   USE dom_ice          ! LIM domain 
     24   USE par_ice          ! LIM parameters 
     25   USE ice              ! LIM variables 
     26   USE limtab           ! LIM 2D <==> 1D 
     27   USE limcons          ! LIM conservation 
     28   USE wrk_nemo         ! workspace manager 
     29   USE in_out_manager   ! I/O manager 
    2430 
    2531   IMPLICIT NONE 
    2632   PRIVATE 
    2733 
    28    !! * Routine accessibility 
    2934   PUBLIC lim_thd_lac     ! called by lim_thd 
    3035 
    31    !! * Module variables 
    32    REAL(wp)  ::           &  ! constant values 
    33       epsi20 = 1.e-20  ,  & 
    34       epsi13 = 1.e-13  ,  & 
    35       epsi11 = 1.e-13  ,  & 
    36       epsi03 = 1.e-03  ,  & 
    37       epsi06 = 1.e-06  ,  & 
    38       zeps   = 1.e-10  ,  & 
    39       zzero  = 0.e0    ,  & 
    40       zone   = 1.e0 
     36   REAL(wp) ::   epsi20 = 1e-20_wp   ! constant values 
     37   REAL(wp) ::   epsi13 = 1e-13_wp   ! 
     38   REAL(wp) ::   epsi11 = 1e-11_wp   ! 
     39   REAL(wp) ::   epsi10 = 1e-10_wp   ! 
     40   REAL(wp) ::   epsi06 = 1e-06_wp   ! 
     41   REAL(wp) ::   epsi03 = 1e-03_wp   ! 
     42   REAL(wp) ::   zzero  = 0._wp      ! 
     43   REAL(wp) ::   zone   = 1._wp      ! 
    4144 
    4245   !!---------------------------------------------------------------------- 
    43    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     46   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    4447   !! $Id$ 
    45    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     48   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    4649   !!---------------------------------------------------------------------- 
    47  
    4850CONTAINS 
    4951 
    … …  
    7375      !!             - Computation of frldb after lateral accretion and  
    7476      !!               update ht_s_b, ht_i_b and tbif_1d(:,:)       
    75       !!  
    76       !! ** References : Not available yet 
    77       !! 
    78       !! History : 
    79       !!   3.0  !  12-05 (M. Vancoppenolle)  Thorough rewrite of the routine 
    80       !!                                     Salinity variations in sea ice,  
    81       !!                                     Multi-layer code 
    82       !!   3.1  !  01-06 (M. Vancoppenolle)  ITD 
    83       !!   3.2  !  04-07 (M. Vancoppenolle)  Mass and energy conservation tested 
    8477      !!------------------------------------------------------------------------ 
    85       !! * Arguments 
    86       !! * Local variables 
    87       INTEGER ::             & 
    88          ji,jj,jk,jl,jm  ,   &  !: dummy loop indices 
    89          layer           ,   &  !: layer index 
    90          nbpac                  !: nb of pts for lateral accretion  
    91  
    92       INTEGER ::             & 
    93          zji             ,   &  !: ji of dummy test point  
    94          zjj             ,   &  !: jj of dummy test point 
    95          iter                   !: iteration for frazil ice computation 
    96  
    97       INTEGER, DIMENSION(jpij) :: & 
    98          zcatac          ,   &  !:  indexes of categories where new ice grows 
    99          zswinew                !: switch for new ice or not 
    100  
    101       REAL(wp), DIMENSION(jpij) :: & 
    102          zv_newice       ,   &  !: volume of accreted ice 
    103          za_newice       ,   &  !: fractional area of accreted ice 
    104          zh_newice       ,   &  !: thickness of accreted ice 
    105          ze_newice       ,   &  !: heat content of accreted ice 
    106          zs_newice       ,   &  !: salinity of accreted ice 
    107          zo_newice       ,   &  !: age of accreted ice 
    108          zdv_res         ,   &  !: residual volume in case of excessive heat budget 
    109          zda_res         ,   &  !: residual area in case of excessive heat budget 
    110          zat_i_ac        ,   &  !: total ice fraction     
    111          zat_i_lev       ,   &  !: total ice fraction for level ice only (type 1)    
    112          zdh_frazb       ,   &  !: accretion of frazil ice at the ice bottom 
    113          zvrel_ac               !: relative ice / frazil velocity (1D vector) 
    114  
    115       REAL(wp), DIMENSION(jpij,jpl) :: & 
    116          zhice_old       ,   &  !: previous ice thickness 
    117          zdummy          ,   &  !: dummy thickness of new ice  
    118          zdhicbot        ,   &  !: thickness of new ice which is accreted vertically 
    119          zv_old          ,   &  !: old volume of ice in category jl 
    120          za_old          ,   &  !: old area of ice in category jl 
    121          za_i_ac         ,   &  !: 1-D version of a_i 
    122          zv_i_ac         ,   &  !: 1-D version of v_i 
    123          zoa_i_ac        ,   &  !: 1-D version of oa_i 
    124          zsmv_i_ac              !: 1-D version of smv_i 
    125  
    126       REAL(wp), DIMENSION(jpij,jkmax,jpl) :: & 
    127          ze_i_ac                !: 1-D version of e_i 
    128  
    129       REAL(wp), DIMENSION(jpij) :: & 
    130          zqbgow          ,   &  !: heat budget of the open water (negative) 
    131          zdhex                  !: excessively thick accreted sea ice (hlead-hice) 
    132  
    133       REAL(wp)  ::           & 
    134          ztmelts         ,   &  !: melting point of an ice layer 
    135          zdv             ,   &  !: increase in ice volume in each category 
    136          zfrazb                 !: fraction of frazil ice accreted at the ice bottom 
    137  
    138       ! Redistribution of energy after bottom accretion 
    139       REAL(wp)  ::           &  !: Energy redistribution 
    140          zqold           ,   &  !: old ice enthalpy 
    141          zweight         ,   &  !: weight of redistribution 
    142          zeps6           ,   &  !: epsilon value 
    143          zalphai         ,   &  !: factor describing how old and new layers overlap each other [m] 
    144          zindb             
    145  
    146       REAL(wp), DIMENSION(jpij,jkmax+1,jpl) :: & 
    147          zqm0            ,   &  !: old layer-system heat content 
    148          zthick0                !: old ice thickness 
    149  
    150       ! Frazil ice collection thickness 
    151       LOGICAL :: &              !: iterate frazil ice collection thickness 
    152          iterate_frazil 
    153  
    154       REAL(wp), DIMENSION(jpi,jpj) :: & 
    155          zvrel                  !: relative ice / frazil velocity 
    156  
    157       REAL(wp) ::            & 
    158          zgamafr          ,  &  !: mult. coeff. between frazil vel. and wind speed 
    159          ztenagm          ,  &  !: square root of wind stress 
    160          zvfrx            ,  &  !: x-component of frazil velocity 
    161          zvfry            ,  &  !: y-component of frazil velocity 
    162          zvgx             ,  &  !: x-component of ice velocity 
    163          zvgy             ,  &  !: y-component of ice velocity 
    164          ztaux            ,  &  !: x-component of wind stress 
    165          ztauy            ,  &  !: y-component of wind stress 
    166          ztwogp           ,  &  !: dummy factor including reduced gravity 
    167          zvrel2           ,  &  !: square of the relative ice-frazil velocity 
    168          zf               ,  &  !: F for Newton-Raphson procedure 
    169          zfp              ,  &  !: dF for Newton-Raphson procedure 
    170          zhicol_new       ,  &  !: updated collection thickness 
    171          zsqcd            ,  &  !: 1 / square root of ( airdensity * drag ) 
    172          zhicrit                !: minimum thickness of frazil ice 
    173  
    174       ! Variables for energy conservation 
    175       REAL (wp), DIMENSION(jpi,jpj) :: &  !  
    176          vt_i_init, vt_i_final,   &  !  ice volume summed over categories 
    177          vt_s_init, vt_s_final,   &  !  snow volume summed over categories 
    178          et_i_init, et_i_final,   &  !  ice energy summed over categories 
    179          et_s_init                   !  snow energy summed over categories 
    180  
    181       REAL(wp) ::            & 
    182          zde                         ! :increment of energy in category jl 
    183  
     78      USE wrk_nemo, ONLY :   vt_i_init => wrk_2d_1 , vt_i_final => wrk_2d_4 , et_i_init => wrk_2d_7 
     79      USE wrk_nemo, ONLY :   vt_s_init => wrk_2d_2 , vt_s_final => wrk_2d_5 , et_s_init => wrk_2d_8 
     80      USE wrk_nemo, ONLY :   zvrel     => wrk_2d_3 , et_i_final => wrk_2d_6  
     81      ! 
     82      INTEGER ::   ji,jj,jk,jl,jm   ! dummy loop indices 
     83      INTEGER ::   layer, nbpac     ! local integers  
     84      INTEGER ::   zji, zjj, iter   !   -       - 
     85      REAL(wp)  ::   ztmelts, zdv, zqold, zfrazb, zweight, zalphai, zindb, zde  ! local scalars 
     86      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      - 
     87      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      - 
     88      LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness 
    18489      CHARACTER (len = 15) :: fieldid 
    185  
     90      ! 
     91      INTEGER, DIMENSION(jpij) ::   zcatac    !  indexes of categories where new ice grows 
     92 
     93      REAL(wp), DIMENSION(jpij,jpl) ::   zhice_old   ! previous ice thickness 
     94      REAL(wp), DIMENSION(jpij,jpl) ::   zdummy      ! dummy thickness of new ice  
     95      REAL(wp), DIMENSION(jpij,jpl) ::   zdhicbot    ! thickness of new ice which is accreted vertically 
     96      REAL(wp), DIMENSION(jpij,jpl) ::   zv_old      ! old volume of ice in category jl 
     97      REAL(wp), DIMENSION(jpij,jpl) ::   za_old      ! old area of ice in category jl 
     98      REAL(wp), DIMENSION(jpij,jpl) ::   za_i_ac     ! 1-D version of a_i 
     99      REAL(wp), DIMENSION(jpij,jpl) ::   zv_i_ac     ! 1-D version of v_i 
     100      REAL(wp), DIMENSION(jpij,jpl) ::   zoa_i_ac    ! 1-D version of oa_i 
     101      REAL(wp), DIMENSION(jpij,jpl) ::   zsmv_i_ac   ! 1-D version of smv_i 
     102 
     103      REAL(wp), DIMENSION(jpij,jkmax  ,jpl) ::   ze_i_ac   !: 1-D version of e_i 
     104      REAL(wp), DIMENSION(jpij,jkmax+1,jpl) ::   zqm0      ! old layer-system heat content 
     105      REAL(wp), DIMENSION(jpij,jkmax+1,jpl) ::   zthick0   ! old ice thickness 
     106 
     107      REAL(wp), POINTER, DIMENSION(:) ::   zv_newice, zh_newice, zs_newice, zdv_res, zat_i_ac , zdh_frazb, zqbgow 
     108      REAL(wp), POINTER, DIMENSION(:) ::   za_newice, ze_newice, zo_newice, zda_res, zat_i_lev, zvrel_ac , zdhex 
     109      REAL(wp), POINTER, DIMENSION(:) ::   zswinew 
    186110      !!-----------------------------------------------------------------------! 
    187111 
    188       et_i_init(:,:) = 0.0 
    189       et_s_init(:,:) = 0.0 
    190       vt_i_init(:,:) = 0.0 
    191       vt_s_init(:,:) = 0.0 
    192       zeps6   = 1.0e-6 
     112      IF(  .NOT. wrk_use(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) .AND.   & 
     113         & .NOT. wrk_use(2, 1,2,3,4,5,6,7,8)                        ) THEN 
     114         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN 
     115      END IF 
     116      ! Set-up pointers to sub-arrays of workspace arrays 
     117      zv_newice =>  wrk_1d_1 (1:jpij)   ! volume of accreted ice 
     118      za_newice =>  wrk_1d_2 (1:jpij)   ! fractional area of accreted ice 
     119      zh_newice =>  wrk_1d_3 (1:jpij)   ! thickness of accreted ice 
     120      ze_newice =>  wrk_1d_4 (1:jpij)   ! heat content of accreted ice 
     121      zs_newice =>  wrk_1d_5 (1:jpij)   ! salinity of accreted ice 
     122      zo_newice =>  wrk_1d_6 (1:jpij)   ! age of accreted ice 
     123      zdv_res   =>  wrk_1d_7 (1:jpij)   ! residual volume in case of excessive heat budget 
     124      zda_res   =>  wrk_1d_8 (1:jpij)   ! residual area in case of excessive heat budget 
     125      zat_i_ac  =>  wrk_1d_9 (1:jpij)   ! total ice fraction 
     126      zat_i_lev =>  wrk_1d_10(1:jpij)   ! total ice fraction for level ice only (type 1)    
     127      zdh_frazb =>  wrk_1d_11(1:jpij)   ! accretion of frazil ice at the ice bottom 
     128      zvrel_ac  =>  wrk_1d_12(1:jpij)   ! relative ice / frazil velocity (1D vector) 
     129      zqbgow    =>  wrk_1d_13(1:jpij)   ! heat budget of the open water (negative) 
     130      zdhex     =>  wrk_1d_14(1:jpij)   ! excessively thick accreted sea ice (hlead-hice) 
     131 
     132 
     133 
     134      et_i_init(:,:) = 0._wp 
     135      et_s_init(:,:) = 0._wp 
     136      vt_i_init(:,:) = 0._wp 
     137      vt_s_init(:,:) = 0._wp 
    193138 
    194139      !------------------------------------------------------------------------------! 
    … …  
    211156                  !Energy of melting q(S,T) [J.m-3] 
    212157                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / & 
    213                      MAX( area(ji,jj) * v_i(ji,jj,jl) ,  zeps ) * & 
     158                     MAX( area(ji,jj) * v_i(ji,jj,jl) ,  epsi10 ) * & 
    214159                     nlay_i 
    215160                  zindb      = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) !0 if no ice and 1 if yes 
    … …  
    273218                  ! Frazil ice velocity 
    274219                  !--------------------- 
    275                   zvfrx         = zgamafr * zsqcd * ztaux / MAX(ztenagm,zeps) 
    276                   zvfry         = zgamafr * zsqcd * ztauy / MAX(ztenagm,zeps) 
     220                  zvfrx         = zgamafr * zsqcd * ztaux / MAX(ztenagm,epsi10) 
     221                  zvfry         = zgamafr * zsqcd * ztauy / MAX(ztenagm,epsi10) 
    277222 
    278223                  !------------------- 
    … …  
    546491         ! Laterally redistribute new ice volume and area 
    547492         !------------------------------------------------ 
    548          zat_i_ac(:) = 0.0 
    549  
     493         zat_i_ac(:) = 0._wp 
    550494         DO jl = 1, jpl 
    551495            DO ji = 1, nbpac 
    552                ! vectorize 
    553                IF (       ( hi_max(jl-1)  .LT. zh_newice(ji) ) & 
    554                   .AND. ( zh_newice(ji) .LE. hi_max(jl)    ) ) THEN 
    555                   za_i_ac(ji,jl) = za_i_ac(ji,jl) + za_newice(ji) 
    556                   zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + zv_newice(ji) 
    557                   zat_i_ac(ji)   = zat_i_ac(ji) + za_i_ac(ji,jl) 
    558                   zcatac(ji)     = jl 
     496               IF(  hi_max   (jl-1)  <  zh_newice(ji)   .AND.   & 
     497                  & zh_newice(ji)    <= hi_max   (jl)         ) THEN 
     498                  za_i_ac (ji,jl) = za_i_ac (ji,jl) + za_newice(ji) 
     499                  zv_i_ac (ji,jl) = zv_i_ac (ji,jl) + zv_newice(ji) 
     500                  zat_i_ac(ji)    = zat_i_ac(ji)    + za_i_ac  (ji,jl) 
     501                  zcatac  (ji)    = jl 
    559502               ENDIF 
    560503            END DO ! ji 
    … …  
    565508         !---------------------------------- 
    566509         DO ji = 1, nbpac 
    567             jl = zcatac(ji) ! categroy in which new ice is put 
    568             ! zindb = 0 if no ice and 1 if yes 
    569             zindb            = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , -za_old(ji,jl) ) )  
    570             ! old ice thickness 
    571             zhice_old(ji,jl)  = zv_old(ji,jl)                                  & 
    572                / MAX ( za_old(ji,jl) , zeps ) * zindb 
    573             ! difference in thickness 
    574             zdhex(ji)      = MAX( 0.0, zh_newice(ji) - zhice_old(ji,jl) )  
    575             ! is ice totally new in category jl ? 
    576             zswinew(ji)    = MAX( 0.0, SIGN( 1.0 , - za_old(ji,jl) + epsi11 ) ) 
     510            jl = zcatac(ji)                                                           ! categroy in which new ice is put 
     511            zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , -za_old(ji,jl) ) )             ! zindb=1 if ice =0 otherwise 
     512            zhice_old(ji,jl) = zv_old(ji,jl) / MAX( za_old(ji,jl) , epsi10 ) * zindb  ! old ice thickness 
     513            zdhex    (ji) = MAX( 0._wp , zh_newice(ji) - zhice_old(ji,jl) )           ! difference in thickness 
     514            zswinew  (ji) = MAX( 0._wp , SIGN( 1._wp , - za_old(ji,jl) + epsi11 ) )   ! ice totally new in jl category 
    577515         END DO 
    578516 
    … …  
    580518            DO ji = 1, nbpac 
    581519               jl = zcatac(ji) 
    582                zqold              = ze_i_ac(ji,jk,jl) ! [ J.m-3 ] 
    583                zalphai            = MIN( zhice_old(ji,jl) * jk  / nlay_i ,     & 
    584                   zh_newice(ji) )                       & 
    585                   - MIN( zhice_old(ji,jl) * ( jk - 1 )         & 
    586                   / nlay_i , zh_newice(ji) ) 
    587                ze_i_ac(ji,jk,jl) =                                             & 
    588                   zswinew(ji)           * ze_newice(ji)                           & 
    589                   + ( 1.0 - zswinew(ji) ) *                                         & 
    590                   ( za_old(ji,jl)  * zqold * zhice_old(ji,jl) / nlay_i            & 
    591                   + za_newice(ji)  * ze_newice(ji) * zalphai                      & 
    592                   + za_newice(ji)  * ze_newice(ji) * zdhex(ji) / nlay_i ) /       & 
    593                   ( ( zv_i_ac(ji,jl) ) / nlay_i ) 
    594  
    595             END DO !ji 
    596          END DO !jl 
     520               zqold   = ze_i_ac(ji,jk,jl) ! [ J.m-3 ] 
     521               zalphai = MIN( zhice_old(ji,jl) *   jk       / nlay_i , zh_newice(ji) )   & 
     522                  &    - MIN( zhice_old(ji,jl) * ( jk - 1 ) / nlay_i , zh_newice(ji) ) 
     523               ze_i_ac(ji,jk,jl) = zswinew(ji) * ze_newice(ji)                                     & 
     524                  + ( 1.0 - zswinew(ji) ) * ( za_old(ji,jl)  * zqold * zhice_old(ji,jl) / nlay_i   & 
     525                  + za_newice(ji)  * ze_newice(ji) * zalphai                                       & 
     526                  + za_newice(ji)  * ze_newice(ji) * zdhex(ji) / nlay_i ) / ( ( zv_i_ac(ji,jl) ) / nlay_i ) 
     527            END DO 
     528         END DO 
    597529 
    598530         !----------------------------------------------- 
    … …  
    605537         ! Fraction of level ice 
    606538         jm = 1 
    607          zat_i_lev(:) = 0.0 
     539         zat_i_lev(:) = 0._wp 
    608540 
    609541         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 
    … …  
    616548         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 
    617549            DO ji = 1, nbpac 
    618                zindb      =  MAX( 0.0, SIGN( 1.0, zdv_res(ji) ) ) 
    619                zv_i_ac(ji,jl) = zv_i_ac(ji,jl) +                               & 
    620                   zindb * zdv_res(ji) * za_i_ac(ji,jl) /         & 
    621                   MAX( zat_i_lev(ji) , epsi06 ) 
    622             END DO ! ji 
    623          END DO ! jl 
    624          IF( ln_nicep ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl) 
     550               zindb = MAX( 0._wp, SIGN( 1._wp , zdv_res(ji) ) ) 
     551               zv_i_ac(ji,jl) = zv_i_ac(ji,jl) + zindb * zdv_res(ji) * za_i_ac(ji,jl) / MAX( zat_i_lev(ji) , epsi06 ) 
     552            END DO 
     553         END DO 
     554         IF( ln_nicep )   WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl) 
    625555 
    626556         !--------------------------------- 
    … …  
    630560         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 
    631561            DO ji = 1, nbpac 
    632                ! zindb = 0 if no ice and 1 if yes 
    633                zindb            =  1.0 -  MAX( 0.0 , SIGN( 1.0                 &  
    634                   , - za_i_ac(ji,jl ) ) )  
    635                zhice_old(ji,jl) =  zv_i_ac(ji,jl) /                            & 
    636                   MAX( za_i_ac(ji,jl) , zeps ) * zindb 
    637                zdhicbot(ji,jl)  =  zdv_res(ji) / MAX( za_i_ac(ji,jl) , zeps )  &  
    638                   *  zindb & 
    639                   +  zindb * zdh_frazb(ji) ! frazil ice  
    640                ! may coalesce 
    641                ! thickness of residual ice 
    642                zdummy(ji,jl)    = zv_i_ac(ji,jl)/MAX(za_i_ac(ji,jl),zeps)*zindb 
    643             END DO !ji 
    644          END DO !jl 
     562               zindb =  1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl ) ) )       ! zindb=1 if ice =0 otherwise 
     563               zhice_old(ji,jl) = zv_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb 
     564               zdhicbot (ji,jl) = zdv_res(ji)    / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb    & 
     565                  &             +  zindb * zdh_frazb(ji)                               ! frazil ice may coalesce 
     566               zdummy(ji,jl)    = zv_i_ac(ji,jl)/MAX(za_i_ac(ji,jl),epsi10)*zindb      ! thickness of residual ice 
     567            END DO 
     568         END DO 
    645569 
    646570         ! old layers thicknesses and enthalpies 
    … …  
    648572            DO jk = 1, nlay_i 
    649573               DO ji = 1, nbpac 
    650                   zthick0(ji,jk,jl)=  zhice_old(ji,jl) / nlay_i 
    651                   zqm0   (ji,jk,jl)=  ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl) 
    652                END DO !ji 
    653             END DO !jk 
    654          END DO !jl 
    655  
     574                  zthick0(ji,jk,jl) =  zhice_old(ji,jl) / nlay_i 
     575                  zqm0   (ji,jk,jl) =  ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl) 
     576               END DO 
     577            END DO 
     578         END DO 
     579!!gm ???  why the previous do loop  if ocerwriten by the following one ? 
    656580         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 
    657581            DO ji = 1, nbpac 
    658582               zthick0(ji,nlay_i+1,jl) =  zdhicbot(ji,jl) 
    659                zqm0   (ji,nlay_i+1,jl) =  ze_newice(ji)*zdhicbot(ji,jl) 
     583               zqm0   (ji,nlay_i+1,jl) =  ze_newice(ji) * zdhicbot(ji,jl) 
    660584            END DO ! ji 
    661585         END DO ! jl 
    662586 
    663587         ! Redistributing energy on the new grid 
    664          ze_i_ac(:,:,:) = 0.0 
     588         ze_i_ac(:,:,:) = 0._wp 
    665589         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2) 
    666590            DO jk = 1, nlay_i 
    667591               DO layer = 1, nlay_i + 1 
    668592                  DO ji = 1, nbpac 
    669                      zindb            =  1.0 -  MAX( 0.0 , SIGN( 1.0 ,         &  
    670                         - za_i_ac(ji,jl ) ) )  
     593                     zindb =  1._wp -  MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) ) )  
    671594                     ! Redistributing energy on the new grid 
    672                      zweight         =  MAX (  & 
    673                         MIN( zhice_old(ji,jl) * layer , zdummy(ji,jl) * jk ) -    & 
    674                         MAX( zhice_old(ji,jl) * ( layer - 1 ) , zdummy(ji,jl) *   & 
    675                         ( jk - 1 ) ) , 0.0 )                                  & 
    676                         /  ( MAX(nlay_i * zthick0(ji,layer,jl),zeps) ) * zindb 
    677                      ze_i_ac(ji,jk,jl) =  ze_i_ac(ji,jk,jl) +                  & 
    678                         zweight * zqm0(ji,layer,jl)   
     595                     zweight = MAX (  MIN( zhice_old(ji,jl) * layer , zdummy(ji,jl) * jk )   & 
     596                        &    - MAX( zhice_old(ji,jl) * ( layer - 1 ) , zdummy(ji,jl) * ( jk - 1 ) ) , 0._wp )   & 
     597                        &    /( MAX(nlay_i * zthick0(ji,layer,jl),epsi10) ) * zindb 
     598                     ze_i_ac(ji,jk,jl) =  ze_i_ac(ji,jk,jl) + zweight * zqm0(ji,layer,jl)   
    679599                  END DO ! ji 
    680600               END DO ! layer 
    … …  
    685605            DO jk = 1, nlay_i 
    686606               DO ji = 1, nbpac 
    687                   zindb                =  1.0 - MAX( 0.0 , SIGN( 1.0           & 
    688                      , - zv_i_ac(ji,jl) ) ) !0 if no ice  
    689                   ze_i_ac(ji,jk,jl)    = ze_i_ac(ji,jk,jl) /                   & 
    690                      MAX( zv_i_ac(ji,jl) , zeps)           & 
    691                      * za_i_ac(ji,jl) * nlay_i * zindb 
     607                  zindb =  1._wp -  MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) ) )  
     608                  ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl)   & 
     609                     &              / MAX( zv_i_ac(ji,jl) , epsi10) * za_i_ac(ji,jl) * nlay_i * zindb 
    692610               END DO 
    693611            END DO 
    … …  
    699617         DO jl = 1, jpl 
    700618            DO ji = 1, nbpac 
    701                !--ice age 
    702                zindb            = 1.0 - MAX( 0.0 , SIGN( 1.0 , -               & 
    703                   za_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes 
    704                zoa_i_ac(ji,jl)  = za_old(ji,jl) * zoa_i_ac(ji,jl) /            & 
    705                   MAX( za_i_ac(ji,jl) , zeps ) * zindb    
    706             END DO ! ji 
    707          END DO ! jl    
     619               zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes 
     620               zoa_i_ac(ji,jl)  = za_old(ji,jl) * zoa_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb    
     621            END DO  
     622         END DO    
    708623 
    709624         !----------------- 
    710625         ! Update salinity 
    711626         !----------------- 
    712          IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 
    713  
     627         IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN 
    714628            DO jl = 1, jpl 
    715629               DO ji = 1, nbpac 
    716                   !zindb = 0 if no ice and 1 if yes 
    717                   zindb            = 1.0 - MAX( 0.0 , SIGN( 1.0 , -               & 
    718                      zv_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes 
    719                   zdv              = zv_i_ac(ji,jl) - zv_old(ji,jl) 
    720                   zsmv_i_ac(ji,jl) = ( zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) ) * & 
    721                      zindb 
    722                END DO ! ji 
    723             END DO ! jl    
    724  
    725          ENDIF ! num_sal 
    726  
     630                  zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes 
     631                  zdv   = zv_i_ac(ji,jl) - zv_old(ji,jl) 
     632                  zsmv_i_ac(ji,jl) = ( zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) ) * zindb 
     633               END DO 
     634            END DO    
     635         ENDIF 
    727636 
    728637         !------------------------------------------------------------------------------! 
    729638         ! 8) Change 2D vectors to 1D vectors  
    730639         !------------------------------------------------------------------------------! 
    731  
    732640         DO jl = 1, jpl 
    733             CALL tab_1d_2d( nbpac, a_i(:,:,jl) , npac(1:nbpac) ,               & 
    734                za_i_ac(1:nbpac,jl) , jpi, jpj ) 
    735             CALL tab_1d_2d( nbpac, v_i(:,:,jl) , npac(1:nbpac) ,               & 
    736                zv_i_ac(1:nbpac,jl) , jpi, jpj ) 
    737             CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac) ,               & 
    738                zoa_i_ac(1:nbpac,jl), jpi, jpj ) 
    739             IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) & 
    740                CALL tab_1d_2d( nbpac, smv_i(:,:,jl) , npac(1:nbpac) ,             & 
    741                zsmv_i_ac(1:nbpac,jl) , jpi, jpj ) 
     641            CALL tab_1d_2d( nbpac, a_i (:,:,jl), npac(1:nbpac), za_i_ac (1:nbpac,jl), jpi, jpj ) 
     642            CALL tab_1d_2d( nbpac, v_i (:,:,jl), npac(1:nbpac), zv_i_ac (1:nbpac,jl), jpi, jpj ) 
     643            CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac), zoa_i_ac(1:nbpac,jl), jpi, jpj ) 
     644            IF (  num_sal == 2  .OR.  num_sal == 4  )   & 
     645               CALL tab_1d_2d( nbpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_ac(1:nbpac,jl) , jpi, jpj ) 
    742646            DO jk = 1, nlay_i 
    743                CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl) , npac(1:nbpac),          & 
    744                   ze_i_ac(1:nbpac,jk,jl), jpi, jpj ) 
    745             END DO ! jk 
    746          END DO !jl 
    747          CALL tab_1d_2d( nbpac, fseqv , npac(1:nbpac), fseqv_1d  (1:nbpac) ,   & 
    748             jpi, jpj ) 
    749  
     647               CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl), npac(1:nbpac), ze_i_ac(1:nbpac,jk,jl), jpi, jpj ) 
     648            END DO 
     649         END DO 
     650         CALL tab_1d_2d( nbpac, fseqv , npac(1:nbpac), fseqv_1d  (1:nbpac) , jpi, jpj ) 
     651         ! 
    750652      ENDIF ! nbpac > 0 
    751653 
    … …  
    753655      ! 9) Change units for e_i 
    754656      !------------------------------------------------------------------------------!     
    755  
    756657      DO jl = 1, jpl 
    757          DO jk = 1, nlay_i 
    758             DO jj = 1, jpj 
    759                DO ji = 1, jpi 
    760                   ! Correct dimensions to avoid big values 
    761                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / unit_fac 
    762  
    763                   ! Mutliply by ice volume, and divide by number  
    764                   ! of layers to get heat content in 10^9 Joules 
    765                   e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * & 
    766                      area(ji,jj) * v_i(ji,jj,jl) / & 
    767                      nlay_i 
    768                END DO 
    769             END DO 
     658         DO jk = 1, nlay_i          ! heat content in 10^9 Joules 
     659            e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * v_i(:,:,jl) / nlay_i  / unit_fac  
    770660         END DO 
    771661      END DO 
    … …  
    774664      ! 10) Conservation check and changes in each ice category 
    775665      !------------------------------------------------------------------------------| 
    776  
    777       IF ( con_i ) THEN  
     666      IF( con_i ) THEN  
    778667         CALL lim_column_sum (jpl,   v_i, vt_i_final) 
    779668         fieldid = 'v_i, limthd_lac' 
    780669         CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid)  
    781  
     670         ! 
    782671         CALL lim_column_sum_energy(jpl, nlay_i, e_i, et_i_final) 
    783672         fieldid = 'e_i, limthd_lac' 
    784673         CALL lim_cons_check (et_i_final, et_i_final, 1.0e-3, fieldid)  
    785  
     674         ! 
    786675         CALL lim_column_sum (jpl,   v_s, vt_s_final) 
    787676         fieldid = 'v_s, limthd_lac' 
    788677         CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid)  
    789  
     678         ! 
    790679         !     CALL lim_column_sum (jpl,   e_s(:,:,1,:) , et_s_init) 
    791680         !     fieldid = 'e_s, limthd_lac' 
    792681         !     CALL lim_cons_check (et_s_init, et_s_final, 1.0e-3, fieldid)  
    793  
    794682         IF( ln_nicep ) THEN 
    795683            WRITE(numout,*) ' vt_i_init : ', vt_i_init(jiindx,jjindx) 
    … …  
    798686            WRITE(numout,*) ' et_i_final: ', et_i_final(jiindx,jjindx) 
    799687         ENDIF 
    800  
     688         ! 
    801689      ENDIF 
    802  
     690      ! 
     691      IF( .NOT. wrk_release(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) .AND.     & 
     692         &.NOT. wrk_release(2, 1,2,3,4,5,6,7,8)                        )   & 
     693         &      CALL ctl_stop( 'lim_thd_lac : failed to release workspace arrays.' ) 
     694      ! 
    803695   END SUBROUTINE lim_thd_lac 
    804696 
    805697#else 
    806    !!====================================================================== 
    807    !!                       ***  MODULE limthd_lac   *** 
    808    !!                           no sea ice model 
    809    !!====================================================================== 
     698   !!---------------------------------------------------------------------- 
     699   !!   Default option                               NO  LIM3 sea-ice model 
     700   !!---------------------------------------------------------------------- 
    810701CONTAINS 
    811702   SUBROUTINE lim_thd_lac           ! Empty routine 
    812703   END SUBROUTINE lim_thd_lac 
    813704#endif 
     705 
     706   !!====================================================================== 
    814707END MODULE limthd_lac 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limthd_sal.F90

    r2528 r2612  
    66   !! History :   -   ! 2003-05 (M. Vancoppenolle) UCL-ASTR first coding for LIM3-1D 
    77   !!            3.0  ! 2005-12 (M. Vancoppenolle) adapted to the 3-D version 
     8   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    89   !!--------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    1617   USE phycst           ! physical constants (ocean directory) 
    1718   USE sbc_oce          ! Surface boundary condition: ocean fields 
    18    USE ice              ! LIM: sea-ice variables 
    19    USE par_ice          ! LIM: sea-ice parameters 
    20    USE thd_ice          ! LIM: sea-ice thermodynamics 
    21    USE limvar           ! LIM: sea-ice variables 
     19   USE ice              ! LIM variables 
     20   USE par_ice          ! LIM parameters 
     21   USE thd_ice          ! LIM thermodynamics 
     22   USE limvar           ! LIM variables 
     23   USE wrk_nemo         ! workspace manager 
    2224   USE in_out_manager   ! I/O manager 
    2325 
    … …  
    2931 
    3032   !!---------------------------------------------------------------------- 
    31    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     33   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    3234   !! $Id$ 
    3335   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    … …  
    5153      INTEGER  ::   ji, jk     ! dummy loop indices  
    5254      INTEGER  ::   zji, zjj   ! local integers 
    53       REAL(wp) ::   zsold, zeps, iflush, iaccrbo, igravdr, isnowic, i_ice_switch,  ztmelts   ! local scalars 
     55      REAL(wp) ::   zsold, iflush, iaccrbo, igravdr, isnowic, i_ice_switch,  ztmelts   ! local scalars 
    5456      REAL(wp) ::   zaaa, zbbb, zccc, zdiscrim   ! local scalars 
    55       REAL(wp), DIMENSION(jpij) ::   ze_init, zhiold, zsiold   ! 1D workspace 
     57      ! 
     58      REAL(wp), POINTER, DIMENSION(:) ::   ze_init, zhiold, zsiold 
    5659      !!--------------------------------------------------------------------- 
    5760 
    58       zeps=1.0e-06_wp 
     61      IF(  .NOT. wrk_use(1, 1,2,3)  ) THEN 
     62         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN 
     63      END IF 
     64      ! Set-up pointers to sub-arrays of workspace arrays 
     65      ze_init =>  wrk_1d_1 (1:jpij) 
     66      zhiold  =>  wrk_1d_2 (1:jpij) 
     67      zsiold  =>  wrk_1d_3 (1:jpij) 
    5968 
    6069      !------------------------------------------------------------------------------| 
    6170      ! 1) Constant salinity, constant in time                                       | 
    6271      !------------------------------------------------------------------------------| 
    63  
     72!!gm comment: if num_sal = 1 s_i_b and sm_i_b can be set to bulk_sal one for all in the initialisation phase !! 
    6473      IF( num_sal == 1 ) THEN 
     74         ! 
    6575         DO jk = 1, nlay_i 
    6676            DO ji = kideb, kiut 
    … …  
    7989      !------------------------------------------------------------------------------| 
    8090 
    81       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 
    82  
    83          !         WRITE(numout,*) 
    84          !         WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    85          !         num_sal 
    86          !         WRITE(numout,*) '~~~~~~~~~~~' 
    87          !         WRITE(numout,*) 
     91      IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN 
    8892 
    8993         !--------------------------------- 
    … …  
    9195         !--------------------------------- 
    9296         DO ji = kideb, kiut 
    93             zhiold(ji)   =  ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) -     & 
    94                dh_i_surf(ji) 
    95          END DO ! ji 
     97            zhiold(ji) = ht_i_b(ji) - dh_i_bott(ji) - dh_snowice(ji) - dh_i_surf(ji) 
     98         END DO 
    9699 
    97100         !--------------------- 
    98101         ! Global heat content 
    99102         !--------------------- 
    100  
    101          ze_init(:)  =  0.0 
     103         ze_init(:)  =  0._wp 
    102104         DO jk = 1, nlay_i 
    103105            DO ji = kideb, kiut 
    104106               ze_init(ji) = ze_init(ji) + q_i_b(ji,jk) * ht_i_b(ji) / nlay_i 
    105             END DO ! ji 
    106          END DO ! jk 
    107  
    108          DO ji = kideb, kiut 
    109  
    110             !---------- 
     107            END DO 
     108         END DO 
     109 
     110         DO ji = kideb, kiut 
     111            ! 
    111112            ! Switches  
    112113            !---------- 
    113  
    114             ! iflush  : 1 if summer  
    115             iflush       =  MAX( 0.0 , SIGN ( 1.0 , t_su_b(ji) - rtt ) )  
    116             ! igravdr : 1 if t_su lt t_bo 
    117             igravdr      =  MAX( 0.0 , SIGN ( 1.0 , t_bo_b(ji) - t_su_b(ji) ) ) 
    118             ! iaccrbo : 1 if bottom accretion 
    119             iaccrbo      =  MAX( 0.0 , SIGN ( 1.0 , dh_i_bott(ji) ) ) 
    120             ! isnowic : 1 if snow ice formation 
    121             i_ice_switch = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - ht_i_b(ji) + 1.0e-2 ) ) 
    122             isnowic      = 1.0 - MAX ( 0.0 , SIGN ( 1.0 , - dh_snowice(ji) ) ) * i_ice_switch 
     114            iflush       =         MAX( 0._wp , SIGN( 1.0 , t_su_b(ji) - rtt )        )    ! =1 if summer  
     115            igravdr      =         MAX( 0._wp , SIGN( 1.0 , t_bo_b(ji) - t_su_b(ji) ) )    ! =1 if t_su < t_bo 
     116            iaccrbo      =         MAX( 0._wp , SIGN( 1.0 , dh_i_bott(ji) )           )    ! =1 if bottom accretion 
     117            i_ice_switch = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - ht_i_b(ji) + 1.e-2 ) ) 
     118            isnowic      = 1._wp - MAX ( 0._wp , SIGN( 1._wp , - dh_snowice(ji) ) ) * i_ice_switch   ! =1 if snow ice formation 
    123119 
    124120            !--------------------- 
    125121            ! Salinity tendencies 
    126122            !--------------------- 
    127  
    128             ! drainage by gravity drainage 
     123            !                                   ! drainage by gravity drainage 
    129124            dsm_i_gd_1d(ji) = - igravdr * MAX( sm_i_b(ji) - sal_G , 0._wp ) / time_G * rdt_ice  
    130  
    131             ! drainage by flushing   
    132             dsm_i_fl_1d(ji)  = - iflush * MAX( sm_i_b(ji) - sal_F , 0._wp ) / time_F * rdt_ice 
     125            !                                   ! drainage by flushing   
     126            dsm_i_fl_1d(ji) = - iflush * MAX( sm_i_b(ji) - sal_F , 0._wp ) / time_F * rdt_ice 
    133127 
    134128            !----------------- 
    135129            ! Update salinity    
    136130            !----------------- 
    137  
    138131            ! only drainage terms ( gravity drainage and flushing ) 
    139             ! snow ice / bottom sources are added in lim_thd_ent 
    140             ! to conserve energy 
     132            ! snow ice / bottom sources are added in lim_thd_ent to conserve energy 
    141133            zsiold(ji) = sm_i_b(ji) 
    142134            sm_i_b(ji) = sm_i_b(ji) + dsm_i_fl_1d(ji) + dsm_i_gd_1d(ji) 
    143135 
    144             ! if no ice, salinity eq 0.1 
     136            ! if no ice, salinity = 0.1 
    145137            i_ice_switch = 1._wp - MAX ( 0._wp, SIGN( 1._wp , - ht_i_b(ji) ) ) 
    146             sm_i_b(ji)   = i_ice_switch*sm_i_b(ji) + s_i_min * ( 1._wp - i_ice_switch ) 
     138            sm_i_b(ji)   = i_ice_switch * sm_i_b(ji) + s_i_min * ( 1._wp - i_ice_switch ) 
    147139         END DO ! ji 
    148140 
    … …  
    155147 
    156148         DO ji = kideb, kiut 
     149!!gm useless 
    157150            ! iflush  : 1 if summer  
    158151            iflush  =  MAX( 0._wp , SIGN ( 1._wp , t_su_b(ji) - rtt ) )  
    … …  
    161154            ! iaccrbo : 1 if bottom accretion 
    162155            iaccrbo =  MAX( 0._wp , SIGN ( 1._wp , dh_i_bott(ji) ) ) 
     156!!gm end useless 
    163157            ! 
    164158            fhbri_1d(ji) = 0._wp 
    … …  
    186180               zbbb         =  ( rcp - cpic ) * ( ztmelts - rtt ) + q_i_b(ji,jk) / rhoic - lfus 
    187181               zccc         =  lfus * ( ztmelts - rtt ) 
    188                zdiscrim     =  SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 
     182               zdiscrim     =  SQRT(  MAX( zbbb*zbbb - 4.0*zaaa*zccc, 0._wp ) ) 
    189183               t_i_b(ji,jk) =  rtt - ( zbbb + zdiscrim ) / ( 2.0 *zaaa ) 
    190             END DO !ji 
    191          END DO !jk 
     184            END DO 
     185         END DO 
    192186         ! 
    193187      ENDIF ! num_sal .EQ. 2 
    … …  
    197191      !------------------------------------------------------------------------------| 
    198192 
    199       IF( num_sal .EQ. 3 ) THEN 
    200  
    201          WRITE(numout,*) 
    202          WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    203             num_sal 
    204          WRITE(numout,*) '~~~~~~~~~~~~' 
    205  
    206          CALL lim_var_salprof1d(kideb,kiut) 
    207  
    208       ENDIF ! num_sal .EQ. 3 
     193      IF( num_sal == 3 )   CALL lim_var_salprof1d( kideb, kiut ) 
    209194 
    210195      !------------------------------------------------------------------------------| 
    … …  
    212197      !------------------------------------------------------------------------------| 
    213198 
    214       ! Cox and Weeks, 1974 
    215       IF (num_sal.eq.5) THEN 
    216  
    217          WRITE(numout,*) 
    218          WRITE(numout,*) 'lim_thd_sal : Ice salinity computation module ', & 
    219             num_sal 
    220          WRITE(numout,*) '~~~~~~~~~~~~' 
    221  
    222          DO ji = kideb, kiut 
    223  
     199      IF( num_sal == 5 ) THEN      ! Cox and Weeks, 1974 
     200         ! 
     201         DO ji = kideb, kiut 
    224202            zsold = sm_i_b(ji) 
    225  
    226             IF (ht_i_b(ji).lt.0.4) THEN 
    227                sm_i_b(ji)    = 14.24 - 19.39*ht_i_b(ji)  
     203            IF( ht_i_b(ji) < 0.4 ) THEN 
     204               sm_i_b(ji) = 14.24 - 19.39 * ht_i_b(ji)  
    228205            ELSE 
    229                sm_i_b(ji)    =  7.88 - 1.59*ht_i_b(ji) 
    230                sm_i_b(ji)    = MIN(sm_i_b(ji),zsold)   
     206               sm_i_b(ji) =  7.88 - 1.59 * ht_i_b(ji) 
     207               sm_i_b(ji) = MIN( sm_i_b(ji) , zsold )   
    231208            ENDIF 
    232  
    233             IF ( ht_i_b(ji) .GT. 3.06918239 ) THEN  
    234                sm_i_b(ji)     = 3.0 
     209            IF( ht_i_b(ji) > 3.06918239 ) THEN  
     210               sm_i_b(ji) = 3._wp 
    235211            ENDIF 
    236  
    237212            DO jk = 1, nlay_i 
    238213               s_i_b(ji,jk)   = sm_i_b(ji) 
    239214            END DO 
    240  
    241          END DO ! ji 
    242  
     215         END DO 
     216         ! 
    243217      ENDIF ! num_sal 
    244218 
    … …  
    247221      !------------------------------------------------------------------------------| 
    248222 
    249       IF ( num_sal .EQ. 4 ) THEN 
    250          DO ji = kideb, kiut 
    251             zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    252             zjj                 = ( npb(ji) - 1 ) / jpi + 1 
     223      IF ( num_sal == 4 ) THEN 
     224         DO ji = kideb, kiut 
     225            zji = MOD( npb(ji) - 1 , jpi ) + 1 
     226            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    253227            fseqv_1d(ji) = fseqv_1d(ji) + ( sss_m(zji,zjj) - bulk_sal    )               & 
    254228               &                        * rhoic * a_i_b(ji) * MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 
    … …  
    256230      ELSE 
    257231         DO ji = kideb, kiut 
    258             zji                 = MOD( npb(ji) - 1, jpi ) + 1 
    259             zjj                 = ( npb(ji) - 1 ) / jpi + 1 
     232            zji = MOD( npb(ji) - 1 , jpi ) + 1 
     233            zjj =    ( npb(ji) - 1 ) / jpi + 1 
    260234            fseqv_1d(ji) = fseqv_1d(ji) + ( sss_m(zji,zjj) - s_i_new(ji) )               & 
    261235               &                        * rhoic * a_i_b(ji) * MAX( dh_i_bott(ji) , 0.0 ) / rdt_ice 
    262          END DO ! ji 
     236         END DO 
    263237      ENDIF 
     238      ! 
     239      IF( .NOT. wrk_release(1, 1,2,3) )   CALL ctl_stop( 'lim_thd_lac : failed to release workspace arrays.' ) 
    264240      ! 
    265241   END SUBROUTINE lim_thd_sal 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limtrp.F90

    r2601 r2612  
    66   !! History : LIM-2 ! 2000-01 (M.A. Morales Maqueda, H. Goosse, and T. Fichefet)  Original code 
    77   !!            3.0  ! 2005-11 (M. Vancoppenolle)   Multi-layer sea ice, salinity variations 
     8   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
    89   !!---------------------------------------------------------------------- 
    910#if defined key_lim3 
    … …  
    4344#  include "vectopt_loop_substitute.h90" 
    4445   !!---------------------------------------------------------------------- 
    45    !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2010) 
     46   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    4647   !! $Id$ 
    4748   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limupdate.F90

    r2528 r2612  
    22   !!====================================================================== 
    33   !!                     ***  MODULE  limupdate  *** 
    4    !!    Update of sea-ice global variables 
    5    !!    at the end of the time step 
    6    !!     
    7    !!    Ice speed from ice dynamics 
    8    !!    Ice thickness, Snow thickness, Temperatures, Lead fraction 
    9    !!      from advection and ice thermodynamics  
     4   !!   LIM-3 : Update of sea-ice global variables at the end of the time step 
    105   !!====================================================================== 
     6   !! History :  3.0  !  2006-04  (M. Vancoppenolle) Original code 
     7   !!---------------------------------------------------------------------- 
    118#if defined key_lim3 
    129   !!---------------------------------------------------------------------- 
    … …  
    1613   !!---------------------------------------------------------------------- 
    1714   USE limrhg          ! ice rheology 
    18    USE lbclnk 
    1915 
    2016   USE dom_oce 
    … …  
    2420   USE sbc_ice         ! Surface boundary condition: ice fields 
    2521   USE dom_ice 
    26    USE phycst          ! Define parameters for the routines 
     22   USE phycst          ! physical constants 
    2723   USE ice 
    28    USE lbclnk 
    2924   USE limdyn 
    3025   USE limtrp 
    … …  
    3833   USE limitd_th 
    3934   USE limvar 
    40    USE prtctl          ! Print control 
    41  
     35   USE prtctl           ! Print control 
     36   USE lbclnk           ! lateral boundary condition - MPP exchanges 
    4237 
    4338   IMPLICIT NONE 
    4439   PRIVATE 
    4540 
    46    !! * Accessibility 
    47    PUBLIC lim_update ! routine called by ice_step 
    48  
     41   PUBLIC   lim_update   ! routine called by ice_step 
     42 
     43      REAL(wp)  ::   epsi06 = 1.e-06_wp   ! module constants 
     44      REAL(wp)  ::   epsi04 = 1.e-04_wp   !    -       - 
     45      REAL(wp)  ::   epsi03 = 1.e-03_wp   !    -       - 
     46      REAL(wp)  ::   epsi10 = 1.e-10_wp   !    -       - 
     47      REAL(wp)  ::   epsi16 = 1.e-16_wp   !    -       - 
     48      REAL(wp)  ::   epsi20 = 1.e-20_wp   !    -       - 
     49      REAL(wp)  ::   rzero  = 0._wp       !    -       - 
     50      REAL(wp)  ::   rone   = 1._wp       !    -       - 
     51          
    4952   !! * Substitutions 
    5053#  include "vectopt_loop_substitute.h90" 
    51  
    5254   !!---------------------------------------------------------------------- 
    53    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     55   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    5456   !! $Id$ 
    55    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
     57   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
    5658   !!---------------------------------------------------------------------- 
    57  
    5859CONTAINS 
    5960 
    … …  
    6768      !!               This place is very important 
    6869      !!                 
    69       !! ** Method  :  Mathematical 
     70      !! ** Method  :   
     71      !!    Ice speed from ice dynamics 
     72      !!    Ice thickness, Snow thickness, Temperatures, Lead fraction 
     73      !!      from advection and ice thermodynamics  
    7074      !! 
    7175      !! ** Action  : -  
    72       !! 
    73       !! History : This routine was new for LIM 3.0  
    74       !!   3.0  !  04-06  (M. Vancoppenolle) Tendencies 
    7576      !!--------------------------------------------------------------------- 
    76       !! * Local variables 
    77       INTEGER ::      & 
    78          ji, jj,     & ! geographical indices 
    79          jk, jl, jm    ! layer, category and type indices 
    80       INTEGER ::      & 
    81          jbnd1, jbnd2 
    82       INTEGER ::      & 
    83          i_ice_switch 
    84  
    85       REAL(wp)  ::           &  ! constant values 
    86          epsi06 = 1.e-06  ,  & 
    87          epsi03 = 1.e-03  ,  & 
    88          epsi16 = 1.e-16  ,  & 
    89          epsi20 = 1.e-20  ,  & 
    90          epsi04 = 1.e-04  ,  & 
    91          epsi10 = 1.e-10  ,  & 
    92          rzero  = 0.e0    ,  & 
    93          rone   = 1.e0    ,  & 
    94          zhimax                   ! maximum thickness tolerated for advection of 
    95       ! in an ice-free cell 
    96       REAL(wp) ::            &  ! dummy switches and arguments 
    97          zindb, zindsn, zindic, zacrith,  & 
    98          zrtt, zindg, zh, zdvres, zviold,                       & 
    99          zbigvalue, zvsold, z_da_ex, zamax,                     & 
    100          z_prescr_hi, zat_i_old,                                & 
    101          ztmelts, ze_s 
    102  
    103       REAL(wp), DIMENSION(jpl) :: z_da_i, z_dv_i 
    104  
    105       LOGICAL, DIMENSION(jpi,jpj,jpl) ::  & 
    106          internal_melt 
    107  
    108       INTEGER ::      & 
    109          ind_im, layer      ! indices for internal melt 
    110       REAL(wp), DIMENSION(jkmax) :: & 
    111          zthick0, zqm0      ! thickness of the layers and heat contents for 
    112       ! internal melt 
    113       REAL(wp) ::                   & 
    114          zweight, zesum 
    115  
    116  
     77      INTEGER ::   ji, jj, jk, jl, jm    ! dummy loop indices 
     78      INTEGER ::   jbnd1, jbnd2 
     79      INTEGER ::   i_ice_switch 
     80      INTEGER ::   ind_im, layer      ! indices for internal melt 
     81      REAL(wp) ::   zweight, zesum, zhimax, z_da_i, z_dv_i 
     82      REAL(wp) ::   zindb, zindsn, zindic, zacrith 
     83      REAL(wp) ::   zrtt, zindg, zh, zdvres, zviold 
     84      REAL(wp) ::   zbigvalue, zvsold, z_da_ex, zamax 
     85      REAL(wp) ::   z_prescr_hi, zat_i_old, ztmelts, ze_s 
     86 
     87      LOGICAL , DIMENSION(jpi,jpj,jpl) ::  internal_melt 
     88      REAL(wp), DIMENSION(jkmax) ::   zthick0, zqm0      ! thickness of the layers and heat contents for 
    11789      !!------------------------------------------------------------------- 
    11890 
    … …  
    139111      ! Ice dynamics   
    140112      !--------------------- 
    141  
    142113      u_ice(:,:) = u_ice(:,:) + d_u_ice_dyn(:,:) 
    143114      v_ice(:,:) = v_ice(:,:) + d_v_ice_dyn(:,:) 
    … …  
    146117      ! Update ice and snow volumes   
    147118      !----------------------------- 
    148  
    149       DO jl = 1, jpl 
    150          DO jj = 1, jpj 
    151             DO ji = 1, jpi 
    152  
    153                v_i(ji,jj,jl)  = v_i(ji,jj,jl) + d_v_i_trp(ji,jj,jl)  & 
    154                   + d_v_i_thd(ji,jj,jl)  
    155                v_s(ji,jj,jl)  = v_s(ji,jj,jl) + d_v_s_trp(ji,jj,jl)  & 
    156                   + d_v_s_thd(ji,jj,jl) 
    157             END DO 
    158          END DO 
     119      DO jl = 1, jpl 
     120         v_i(:,:,jl)  = v_i(:,:,jl) + d_v_i_trp(:,:,jl) + d_v_i_thd(:,:,jl)  
     121         v_s(:,:,jl)  = v_s(:,:,jl) + d_v_s_trp(:,:,jl) + d_v_s_thd(:,:,jl) 
    159122      END DO 
    160123 
    … …  
    168131      ! with negative advection, very pathological ) 
    169132      ! (5) v_i (old) = 0; d_v_i_trp > 0 (advection of ice in a free-cell) 
    170  
     133      ! 
    171134      DO jl = 1, jpl 
    172135         DO jj = 1, jpj 
    173136            DO ji = 1, jpi 
    174137               patho_case(ji,jj,jl) = 1 
    175                IF ( v_i(ji,jj,jl) .GE. 0.0 ) THEN 
     138               IF( v_i(ji,jj,jl) .GE. 0.0 ) THEN 
    176139                  IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN  
    177140                     patho_case(ji,jj,jl) = 2 
    … …  
    179142               ELSE 
    180143                  patho_case(ji,jj,jl) = 3 
    181                   IF ( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN  
     144                  IF( old_v_i(ji,jj,jl) + d_v_i_thd(ji,jj,jl) .LT. epsi10 ) THEN  
    182145                     patho_case(ji,jj,jl) = 4 
    183146                  ENDIF 
    184147               ENDIF 
    185                IF ( ( old_v_i(ji,jj,jl) .LE. epsi10 ) .AND. & 
    186                   ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 
     148               IF( ( old_v_i(ji,jj,jl) .LE. epsi10 ) .AND. & 
     149                   ( d_v_i_trp(ji,jj,jl) .GT. epsi06 ) ) THEN 
    187150                  patho_case(ji,jj,jl) = 5 ! advection of ice in an ice-free 
    188151                  ! cell 
    … …  
    229192                  v_i(ji,jj,jl) = zindic*v_i(ji,jj,jl)    !ice volume cannot be negative 
    230193                  !correct thermodynamic ablation 
    231                   d_v_i_thd(ji,jj,jl)  = zindic  *  d_v_i_thd(ji,jj,jl) + &  
    232                      (1.0-zindic) * (-zviold - d_v_i_trp(ji,jj,jl))  
     194                  d_v_i_thd(ji,jj,jl)  = zindic  *  d_v_i_thd(ji,jj,jl) + (1.0-zindic) * (-zviold - d_v_i_trp(ji,jj,jl))  
    233195                  ! THIS IS NEW 
    234196                  d_a_i_thd(ji,jj,jl)  = zindic  *  d_a_i_thd(ji,jj,jl) + &  
    … …  
    252214 
    253215                  !residual salt flux if snow is over-molten 
    254                   fsalt_res(ji,jj)  = fsalt_res(ji,jj) + sss_m(ji,jj) * &  
    255                      ( rhosn * zdvres / rdt_ice ) 
     216                  fsalt_res(ji,jj)  = fsalt_res(ji,jj) + sss_m(ji,jj) * ( rhosn * zdvres / rdt_ice ) 
    256217                  !this flux will be positive if snow was over-molten 
    257218                  !             fheat_res(ji,jj)  = fheat_res(ji,jj) + rhosn * lfus * zdvres / rdt_ice 
    … …  
    288249      !--------------------------------------------- 
    289250 
    290       a_i (:,:,:) = a_i (:,:,:)   + d_a_i_trp(:,:,:)     & 
    291          + d_a_i_thd(:,:,:) 
    292       CALL lim_var_glo2eqv ! useless, just for debug 
     251      a_i (:,:,:) = a_i (:,:,:) + d_a_i_trp(:,:,:) + d_a_i_thd(:,:,:) 
     252      CALL lim_var_glo2eqv    ! useless, just for debug 
    293253      IF( ln_nicep ) THEN  
    294254         DO jk = 1, nlay_i 
    … …  
    297257      ENDIF 
    298258      e_i(:,:,:,:) = e_i(:,:,:,:) + d_e_i_trp(:,:,:,:)   
    299       CALL lim_var_glo2eqv ! useless, just for debug 
     259      CALL lim_var_glo2eqv    ! useless, just for debug 
    300260      IF( ln_nicep) THEN 
    301       WRITE(numout,*) ' After transport update ' 
     261         WRITE(numout,*) ' After transport update ' 
    302262         DO jk = 1, nlay_i 
    303263            WRITE(numout,*) ' t_i : ', t_i(jiindx, jjindx, jk, 1:jpl) 
    … …  
    313273      ENDIF 
    314274 
    315       at_i(:,:) = 0.0 
     275      at_i(:,:) = 0._wp 
    316276      DO jl = 1, jpl 
    317277         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    … …  
    335295      ! Snow temperature and ice age 
    336296      !------------------------------ 
    337  
    338       e_s(:,:,:,:) = e_s(:,:,:,:)        + & 
    339          d_e_s_trp(:,:,:,:)  + & 
    340          d_e_s_thd(:,:,:,:) 
    341  
    342       oa_i(:,:,:)  = oa_i(:,:,:)         + & 
    343          d_oa_i_trp(:,:,:)   + & 
    344          d_oa_i_thd(:,:,:) 
     297      e_s (:,:,:,:) = e_s (:,:,:,:) + d_e_s_trp (:,:,:,:) + d_e_s_thd (:,:,:,:) 
     298      oa_i(:,:,:)   = oa_i(:,:,:)   + d_oa_i_trp(:,:,:)   + d_oa_i_thd(:,:,:) 
    345299 
    346300      !-------------- 
    … …  
    348302      !-------------- 
    349303 
    350       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN ! general case 
    351  
     304      IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN      ! general case 
     305         ! 
    352306         IF( ln_nicep ) THEN   
    353307            WRITE(numout,*) ' Before everything ' 
    … …  
    360314         ENDIF 
    361315 
    362          smv_i(:,:,:) = smv_i(:,:,:)       + & 
    363             d_smv_i_thd(:,:,:) + & 
    364             d_smv_i_trp(:,:,:) 
    365  
     316         smv_i(:,:,:) = smv_i(:,:,:) + d_smv_i_thd(:,:,:) + d_smv_i_trp(:,:,:) 
     317         ! 
    366318         IF( ln_nicep ) THEN   
    367319            WRITE(numout,*) ' After advection   ' 
    … …  
    369321            WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 
    370322         ENDIF 
    371  
    372       ENDIF ! num_sal .EQ. 2 
     323         ! 
     324      ENDIF 
    373325 
    374326      CALL lim_var_glo2eqv 
    … …  
    377329      ! 2. Review of all pathological cases 
    378330      !-------------------------------------- 
    379  
    380       zrtt          = 173.15 * rone 
    381       zacrith       = 1.0e-6 
     331      zrtt    = 173.15_wp * rone 
     332      zacrith = 1.e-6_wp 
    382333 
    383334      !------------------------------------------- 
    … …  
    386337      ! should be removed since it is treated after dynamics now 
    387338 
    388       zhimax = 5.0 
     339      zhimax = 5._wp 
    389340      ! first category 
    390341      DO jj = 1, jpj 
    … …  
    416367 
    417368      !change this 14h44 
    418       zhimax = 20.0 ! line added up 
     369      zhimax = 20.0     ! line added up 
    419370      ! change this also 17 aug 
    420       zhimax = 30.0 ! line added up 
     371      zhimax = 30.0     ! line added up 
    421372 
    422373      DO jl = 2, jpl 
    … …  
    435386                  .AND.(v_i(ji,jj,jl)/MAX(a_i(ji,jj,jl),epsi10)*zindb).GT.zhimax ) THEN 
    436387                  z_prescr_hi  =  ( hi_max_typ(jl-ice_cat_bounds(jm,1)  ,jm) + & 
    437                      hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) / & 
    438                      2.0 
    439                   a_i(ji,jj,jl) = v_i(ji,jj,jl) / z_prescr_hi 
     388                     hi_max_typ(jl-ice_cat_bounds(jm,1)+1,jm) ) / 2.0 
     389                  a_i (ji,jj,jl) = v_i(ji,jj,jl) / z_prescr_hi 
    440390                  ht_i(ji,jj,jl) = v_i(ji,jj,jl) / a_i(ji,jj,jl) 
    441391               ENDIF 
    … …  
    458408      ENDIF 
    459409 
    460       at_i(:,:) = 0.0 
     410      at_i(:,:) = 0._wp 
    461411      DO jl = 1, jpl 
    462412         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    … …  
    481431         jbnd1 = ice_cat_bounds(jm,1) 
    482432         jbnd2 = ice_cat_bounds(jm,2) 
    483          IF (ice_ncat_types(jm) .GT. 1 ) CALL lim_itd_th_reb(jbnd1, jbnd2, jm) 
     433         IF (ice_ncat_types(jm) .GT. 1 )   CALL lim_itd_th_reb(jbnd1, jbnd2, jm) 
    484434      END DO 
    485435 
    … …  
    498448      ENDIF 
    499449 
    500       at_i(:,:) = 0.0 
     450      at_i(:,:) = 0._wp 
    501451      DO jl = 1, jpl 
    502452         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    … …  
    531481         DO jj = 1, jpj  
    532482            DO ji = 1, jpi 
    533                IF ( internal_melt(ji,jj,jl) ) THEN 
     483               IF( internal_melt(ji,jj,jl) ) THEN 
    534484                  ! initial ice thickness 
    535485                  !----------------------- 
    … …  
    852802      ! 2.13.2) Total ice concentration cannot exceed zamax 
    853803      !---------------------------------------------------- 
    854       at_i(:,:) = 0.0 
    855       DO jl = 1, jpl 
     804      at_i(:,:) = a_i(:,:,1) 
     805      DO jl = 2, jpl 
    856806         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    857807      END DO 
    … …  
    867817               zindb   =  MAX( rzero, SIGN( rone, v_i(ji,jj,jl) - epsi03 ) )  
    868818               zindb   =  MAX( rzero, SIGN( rone, v_i(ji,jj,jl) ) )  
    869                z_da_i(jl) = a_i(ji,jj,jl)*zindb*z_da_ex/MAX(at_i(ji,jj),epsi06) 
    870                z_dv_i(jl) = v_i(ji,jj,jl)*z_da_i(jl)/MAX(at_i(ji,jj),epsi06) 
    871                a_i(ji,jj,jl) = a_i(ji,jj,jl) - z_da_i(jl) 
    872                v_i(ji,jj,jl) = v_i(ji,jj,jl) + z_dv_i(jl) 
    873  
     819               z_da_i = a_i(ji,jj,jl) * z_da_ex / MAX( at_i(ji,jj), epsi06 ) * zindb 
     820               z_dv_i = v_i(ji,jj,jl) * z_da_i  / MAX( at_i(ji,jj), epsi06 ) 
     821               a_i(ji,jj,jl) = a_i(ji,jj,jl) - z_da_i 
     822               v_i(ji,jj,jl) = v_i(ji,jj,jl) + z_dv_i 
    874823            END DO 
    875824 
    … …  
    879828      IF( ln_nicep ) THEN   
    880829         WRITE(numout,*) ' 2.13 ' 
    881          WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl) 
    882          WRITE(numout,*) ' at_i    ', at_i(jiindx,jjindx) 
    883          WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl) 
    884          WRITE(numout,*) ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 
    885          WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 
    886       ENDIF 
    887  
    888       at_i(:,:) = 0.0 
    889       DO jl = 1, jpl 
     830         WRITE(numout,*) ' a_i : ', a_i(jiindx, jjindx, 1:jpl), ' at_i    ', at_i(jiindx,jjindx) 
     831         WRITE(numout,*) ' v_i : ', v_i(jiindx, jjindx, 1:jpl), ' v_s : ', v_s(jiindx, jjindx, 1:jpl) 
     832         WRITE(numout,*) ' smv_i: ', smv_i(jiindx, jjindx, 1:jpl) 
     833      ENDIF 
     834 
     835      at_i(:,:) = a_i(:,:,1) 
     836      DO jl = 2, jpl 
    890837         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    891838      END DO 
    … …  
    941888      ENDIF 
    942889 
    943       at_i(:,:) = 0.0 
    944       DO jl = 1, jpl 
     890      at_i(:,:) = a_i(:,:,1) 
     891      DO jl = 2, jpl 
    945892         at_i(:,:) = a_i(:,:,jl) + at_i(:,:) 
    946893      END DO 
    … …  
    951898      ! Ice drift 
    952899      !------------ 
    953  
    954900      DO jj = 2, jpjm1 
    955901         DO ji = fs_2, fs_jpim1 
    … …  
    976922         DO jj = 1, jpj 
    977923            DO ji = 1, jpi 
    978                DO jl = 1, jpl 
    979                   !                IF ((v_i(ji,jj,jl).NE.0.0).AND.(a_i(ji,jj,jl).EQ.0.0)) THEN 
    980                   !                   WRITE(numout,*) ' lim_update : incompatible volume and concentration ' 
    981                END DO ! jl 
    982  
    983924               DO jl = 1, jpl 
    984925                  IF ( (a_i(ji,jj,jl).GT.1.0).OR.(at_i(ji,jj).GT.1.0) ) THEN 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limvar.F90

    r2528 r2612  
    11MODULE limvar 
    2    !!---------------------------------------------------------------------- 
    3    !!   'key_lim3'                                      LIM3 sea-ice model 
    4    !!---------------------------------------------------------------------- 
    52   !!====================================================================== 
    63   !!                       ***  MODULE limvar *** 
    … …  
    3229   !!                        - ot_i(jpi,jpj)  !average ice age 
    3330   !!====================================================================== 
     31   !! History :   -   ! 2006-01 (M. Vancoppenolle) Original code 
     32   !!            4.0  ! 2011-02 (G. Madec) dynamical allocation 
     33   !!---------------------------------------------------------------------- 
    3434#if defined key_lim3 
    3535   !!---------------------------------------------------------------------- 
    36    !! * Modules used 
    37    USE dom_ice 
     36   !!   'key_lim3'                                      LIM3 sea-ice model 
     37   !!---------------------------------------------------------------------- 
     38   !!   lim_var_agg       :  
     39   !!   lim_var_glo2eqv   : 
     40   !!   lim_var_eqv2glo   : 
     41   !!   lim_var_salprof   :  
     42   !!   lim_var_salprof1d : 
     43   !!   lim_var_bv        : 
     44   !!---------------------------------------------------------------------- 
    3845   USE par_oce          ! ocean parameters 
    3946   USE phycst           ! physical constants (ocean directory)  
    4047   USE sbc_oce          ! Surface boundary condition: ocean fields 
    41    USE thd_ice 
    42    USE in_out_manager 
    43    USE ice 
    44    USE par_ice 
     48   USE ice              ! LIM variables 
     49   USE par_ice          ! LIM parameters 
     50   USE dom_ice          ! LIM domain 
     51   USE thd_ice          ! LIM thermodynamics 
     52   USE wrk_nemo         ! workspace manager 
     53   USE in_out_manager   ! I/O manager 
    4554 
    4655   IMPLICIT NONE 
    4756   PRIVATE 
    4857 
    49    !! * Routine accessibility 
    50    PUBLIC lim_var_agg 
    51    PUBLIC lim_var_glo2eqv 
    52    PUBLIC lim_var_eqv2glo 
    53    PUBLIC lim_var_salprof 
    54    PUBLIC lim_var_bv 
    55    PUBLIC lim_var_salprof1d 
    56  
    57    !! * Module variables 
    58    REAL(wp)  ::           &  ! constant values 
    59       epsi20 = 1e-20   ,  & 
    60       epsi13 = 1e-13   ,  & 
    61       zzero  = 0.e0    ,  & 
    62       zone   = 1.e0 
    63  
    64    !!---------------------------------------------------------------------- 
    65    !! NEMO/LIM3 3.3 , UCL - NEMO Consortium (2010) 
     58   PUBLIC   lim_var_agg          ! 
     59   PUBLIC   lim_var_glo2eqv      ! 
     60   PUBLIC   lim_var_eqv2glo      ! 
     61   PUBLIC   lim_var_salprof      ! 
     62   PUBLIC   lim_var_bv           ! 
     63   PUBLIC   lim_var_salprof1d    ! 
     64 
     65   REAL(wp) ::   eps20 = 1.e-20_wp   ! module constants 
     66   REAL(wp) ::   eps16 = 1.e-16_wp   !    -       - 
     67   REAL(wp) ::   eps13 = 1.e-13_wp   !    -       - 
     68   REAL(wp) ::   eps10 = 1.e-10_wp   !    -       - 
     69   REAL(wp) ::   eps06 = 1.e-06_wp   !    -       - 
     70   REAL(wp) ::   zzero = 0.e0        !    -       - 
     71   REAL(wp) ::   zone  = 1.e0        !    -       - 
     72 
     73   !!---------------------------------------------------------------------- 
     74   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011) 
    6675   !! $Id$ 
    67    !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 
    68    !!---------------------------------------------------------------------- 
    69  
    70  
     76   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt) 
     77   !!---------------------------------------------------------------------- 
    7178CONTAINS 
    7279 
    73    SUBROUTINE lim_var_agg(n) 
     80   SUBROUTINE lim_var_agg( kn ) 
    7481      !!------------------------------------------------------------------ 
    7582      !!                ***  ROUTINE lim_var_agg  *** 
    76       !! ** Purpose : 
    77       !!        This routine aggregates ice-thickness-category variables to   
    78       !!                                all-ice variables 
    79       !!        i.e. it turns VGLO into VAGG 
     83      !! 
     84      !! ** Purpose :   aggregates ice-thickness-category variables to all-ice variables 
     85      !!              i.e. it turns VGLO into VAGG 
    8086      !! ** Method  : 
    8187      !! 
    82       !! ** Arguments : 
    83       !!           kideb , kiut : Starting and ending points on which the  
    84       !!                         the computation is applied 
    85       !! 
    86       !! ** Inputs / Ouputs : (global commons) 
    8788      !! ** Arguments : n = 1, at_i vt_i only 
    8889      !!                n = 2 everything 
    8990      !! 
    90       !! ** External :  
    91       !! 
    92       !! ** References : 
    93       !! 
    94       !! ** History : 
    95       !!           (01-2006) Martin Vancoppenolle, UCL-ASTR 
    96       !! 
    9791      !! note : you could add an argument when you need only at_i, vt_i 
    9892      !!        and when you need everything 
    9993      !!------------------------------------------------------------------ 
    100       !! * Arguments 
    101  
    102       !! * Local variables 
    103       INTEGER ::   ji,       &   ! spatial dummy loop index 
    104          jj,       &   ! spatial dummy loop index 
    105          jk,       &   ! vertical layering dummy loop index 
    106          jl            ! ice category dummy loop index 
    107  
    108       REAL ::      zeps, epsi16, zinda, epsi06 
    109  
    110       INTEGER, INTENT( in ) ::   n     ! describes what is needed 
    111  
    112       !!-- End of declarations 
    113       !!---------------------------------------------------------------------------------------------- 
    114       zeps = 1.0e-13 
    115       epsi16 = 1.0e-16 
    116       epsi06 = 1.0e-6 
    117  
    118       !------------------ 
    119       ! Zero everything 
    120       !------------------ 
    121  
    122       vt_i(:,:)  = 0.0 
    123       vt_s(:,:)  = 0.0 
    124       at_i(:,:)  = 0.0  
    125       ato_i(:,:) = 1.0  
    126  
    127       IF ( n .GT. 1 ) THEN 
    128          et_s(:,:)  = 0.0 
    129          ot_i(:,:)  = 0.0 
    130          smt_i(:,:) = 0.0 
    131          et_i(:,:)  = 0.0 
    132       ENDIF 
     94      INTEGER, INTENT( in ) ::   kn     ! =1 at_i & vt only ; = what is needed 
     95      ! 
     96      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
     97      REAL(wp) ::   zinda 
     98      !!------------------------------------------------------------------ 
    13399 
    134100      !-------------------- 
    135101      ! Compute variables 
    136102      !-------------------- 
    137  
     103      vt_i (:,:) = 0._wp 
     104      vt_s (:,:) = 0._wp 
     105      at_i (:,:) = 0._wp 
     106      ato_i(:,:) = 1._wp 
     107      ! 
    138108      DO jl = 1, jpl 
    139109         DO jj = 1, jpj 
    140110            DO ji = 1, jpi 
    141  
     111               ! 
    142112               vt_i(ji,jj) = vt_i(ji,jj) + v_i(ji,jj,jl) ! ice volume 
    143113               vt_s(ji,jj) = vt_s(ji,jj) + v_s(ji,jj,jl) ! snow volume 
    144114               at_i(ji,jj) = at_i(ji,jj) + a_i(ji,jj,jl) ! ice concentration 
    145  
     115               ! 
    146116               zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - 0.10 ) )  
    147                icethi(ji,jj) = vt_i(ji,jj) / MAX(at_i(ji,jj),epsi16)*zinda   
    148                ! ice thickness 
     117               icethi(ji,jj) = vt_i(ji,jj) / MAX( at_i(ji,jj) , eps16 ) * zinda  ! ice thickness 
    149118            END DO 
    150119         END DO 
    … …  
    153122      DO jj = 1, jpj 
    154123         DO ji = 1, jpi 
    155             ato_i(ji,jj) = MAX(1.0 - at_i(ji,jj), 0.0)   ! open water fraction 
    156          END DO 
    157       END DO 
    158  
    159       IF ( n .GT. 1 ) THEN 
    160  
     124            ato_i(ji,jj) = MAX( 1._wp - at_i(ji,jj), 0._wp )   ! open water fraction 
     125         END DO 
     126      END DO 
     127 
     128      IF( kn > 1 ) THEN 
     129         et_s (:,:) = 0._wp 
     130         ot_i (:,:) = 0._wp 
     131         smt_i(:,:) = 0._wp 
     132         et_i (:,:) = 0._wp 
     133         ! 
    161134         DO jl = 1, jpl 
    162135            DO jj = 1, jpj 
    163136               DO ji = 1, jpi 
    164                   et_s(ji,jj)  = et_s(ji,jj)  +     &       ! snow heat content 
    165                      e_s(ji,jj,1,jl) 
     137                  et_s(ji,jj)  = et_s(ji,jj)  + e_s(ji,jj,1,jl)                                       ! snow heat content 
    166138                  zinda = MAX( zzero , SIGN( zone , vt_i(ji,jj) - 0.10 ) )  
    167                   smt_i(ji,jj) = smt_i(ji,jj) +     &       ! ice salinity 
    168                      smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , zeps ) * & 
    169                      zinda 
     139                  smt_i(ji,jj) = smt_i(ji,jj) + smv_i(ji,jj,jl) / MAX( vt_i(ji,jj) , eps13 ) * zinda   ! ice salinity 
    170140                  zinda = MAX( zzero , SIGN( zone , at_i(ji,jj) - 0.10 ) )  
    171                   ot_i(ji,jj)  = ot_i(ji,jj)  +     &       ! ice age 
    172                      oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , zeps ) * & 
    173                      zinda 
    174                END DO 
    175             END DO 
    176          END DO 
    177  
     141                  ot_i(ji,jj)  = ot_i(ji,jj)  + oa_i(ji,jj,jl)  / MAX( at_i(ji,jj) , eps13 ) * zinda   ! ice age 
     142               END DO 
     143            END DO 
     144         END DO 
     145         ! 
    178146         DO jl = 1, jpl 
    179147            DO jk = 1, nlay_i 
    180                DO jj = 1, jpj 
    181                   DO ji = 1, jpi 
    182                      et_i(ji,jj) = et_i(ji,jj) + e_i(ji,jj,jk,jl) ! ice heat 
    183                      ! content 
    184                   END DO 
    185                END DO 
    186             END DO 
    187          END DO 
    188  
    189       ENDIF ! n .GT. 1 
    190  
     148               et_i(:,:) = et_i(:,:) + e_i(:,:,jk,jl)       ! ice heat content 
     149            END DO 
     150         END DO 
     151         ! 
     152      ENDIF 
     153      ! 
    191154   END SUBROUTINE lim_var_agg 
    192155 
    193    !============================================================================== 
    194156 
    195157   SUBROUTINE lim_var_glo2eqv 
    196158      !!------------------------------------------------------------------ 
    197       !!                ***  ROUTINE lim_var_glo2eqv ***' 
    198       !! ** Purpose : 
    199       !!        This routine computes equivalent variables as function of     
    200       !!                              global variables  
    201       !!        i.e. it turns VGLO into VEQV 
    202       !! ** Method  : 
    203       !! 
    204       !! ** Arguments : 
    205       !!           kideb , kiut : Starting and ending points on which the  
    206       !!                         the computation is applied 
    207       !! 
    208       !! ** Inputs / Ouputs :  
    209       !! 
    210       !! ** External :  
    211       !! 
    212       !! ** References : 
    213       !! 
    214       !! ** History : 
    215       !!           (01-2006) Martin Vancoppenolle, UCL-ASTR 
    216       !! 
    217       !!------------------------------------------------------------------ 
    218  
    219       !! * Local variables 
    220       INTEGER ::   ji,       &   ! spatial dummy loop index 
    221          jj,       &   ! spatial dummy loop index 
    222          jk,       &   ! vertical layering dummy loop index 
    223          jl            ! ice category dummy loop index 
    224  
    225       REAL :: zq_i, zaaa, zbbb, zccc, zdiscrim, & 
    226          ztmelts, zindb, zq_s, zfac1, zfac2 
    227  
    228       REAL :: zeps, epsi06 
    229  
    230       zeps    = 1.0e-10 
    231       epsi06  = 1.0e-06 
    232  
    233       !!-- End of declarations 
    234       !!------------------------------------------------------------------------------ 
     159      !!                ***  ROUTINE lim_var_glo2eqv *** 
     160      !! 
     161      !! ** Purpose :   computes equivalent variables as function of global variables  
     162      !!              i.e. it turns VGLO into VEQV 
     163      !!------------------------------------------------------------------ 
     164      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
     165      REAL(wp) ::   zq_i, zaaa, zbbb, zccc, zdiscrim     ! local scalars 
     166      REAL(wp) ::   ztmelts, zindb, zq_s, zfac1, zfac2   !   -      - 
     167      !!------------------------------------------------------------------ 
    235168 
    236169      !------------------------------------------------------- 
    237170      ! Ice thickness, snow thickness, ice salinity, ice age 
    238171      !------------------------------------------------------- 
    239 !CDIR NOVERRCHK 
    240172      DO jl = 1, jpl 
    241 !CDIR NOVERRCHK 
    242173         DO jj = 1, jpj 
    243 !CDIR NOVERRCHK 
    244174            DO ji = 1, jpi 
    245                zindb          = 1.0-MAX(0.0,SIGN(1.0,- a_i(ji,jj,jl))) !0 if no ice and 1 if yes 
    246                ht_i(ji,jj,jl) = v_i(ji,jj,jl)   / MAX( a_i(ji,jj,jl) , zeps ) * zindb 
    247                ht_s(ji,jj,jl) = v_s(ji,jj,jl)   / MAX( a_i(ji,jj,jl) , zeps ) * zindb 
    248                o_i(ji,jj,jl)  = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , zeps ) * zindb 
    249             END DO 
    250          END DO 
    251       END DO 
    252  
    253       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) )THEN 
    254  
    255 !CDIR NOVERRCHK 
     175               zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) ) )   !0 if no ice and 1 if yes 
     176               ht_i(ji,jj,jl) = v_i (ji,jj,jl) / MAX( a_i(ji,jj,jl) , eps10 ) * zindb 
     177               ht_s(ji,jj,jl) = v_s (ji,jj,jl) / MAX( a_i(ji,jj,jl) , eps10 ) * zindb 
     178               o_i(ji,jj,jl)  = oa_i(ji,jj,jl) / MAX( a_i(ji,jj,jl) , eps10 ) * zindb 
     179            END DO 
     180         END DO 
     181      END DO 
     182 
     183      IF(  num_sal == 2  .OR.  num_sal == 4  )THEN 
    256184         DO jl = 1, jpl 
    257 !CDIR NOVERRCHK 
    258             DO jj = 1, jpj 
    259 !CDIR NOVERRCHK 
    260                DO ji = 1, jpi 
    261                   zindb          = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 
    262                   sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX(v_i(ji,jj,jl),zeps) * zindb 
    263                END DO 
    264             END DO 
    265          END DO 
    266  
     185            DO jj = 1, jpj 
     186               DO ji = 1, jpi 
     187                  zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp,- a_i(ji,jj,jl) ) )   !0 if no ice and 1 if yes 
     188                  sm_i(ji,jj,jl) = smv_i(ji,jj,jl) / MAX( v_i(ji,jj,jl) , eps10 ) * zindb 
     189               END DO 
     190            END DO 
     191         END DO 
    267192      ENDIF 
    268193 
    269       ! salinity profile 
    270       CALL lim_var_salprof 
     194      CALL lim_var_salprof      ! salinity profile 
    271195 
    272196      !------------------- 
    … …  
    281205!CDIR NOVERRCHK 
    282206               DO ji = 1, jpi 
    283                   !Energy of melting q(S,T) [J.m-3] 
    284                   zq_i       = e_i(ji,jj,jk,jl) / area(ji,jj) / & 
    285                      MAX( v_i(ji,jj,jl) , epsi06 ) * nlay_i  
    286                   ! zindb = 0 if no ice and 1 if yes 
    287                   zindb      = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) ) ) 
    288                   !convert units ! very important that this line is here 
    289                   zq_i       = zq_i * unit_fac * zindb 
    290                   !Ice layer melt temperature 
    291                   ztmelts    =  -tmut*s_i(ji,jj,jk,jl) + rtt 
    292                   !Conversion q(S,T) -> T (second order equation) 
    293                   zaaa       =  cpic 
    294                   zbbb       =  ( rcp - cpic ) * ( ztmelts - rtt ) + & 
    295                      zq_i / rhoic - lfus 
     207                  !                                                              ! Energy of melting q(S,T) [J.m-3] 
     208                  zq_i    = e_i(ji,jj,jk,jl) / area(ji,jj) / MAX( v_i(ji,jj,jl) , eps06 ) * REAL(nlay_i,wp)  
     209                  zindb   = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_i(ji,jj,jl) ) )     ! zindb = 0 if no ice and 1 if yes 
     210                  zq_i    = zq_i * unit_fac * zindb                              !convert units 
     211                  ztmelts = -tmut * s_i(ji,jj,jk,jl) + rtt                       ! Ice layer melt temperature 
     212                  ! 
     213                  zaaa       =  cpic                  ! Conversion q(S,T) -> T (second order equation) 
     214                  zbbb       =  ( rcp - cpic ) * ( ztmelts - rtt ) + zq_i / rhoic - lfus 
    296215                  zccc       =  lfus * (ztmelts-rtt) 
    297                   zdiscrim   =  SQRT( MAX(zbbb*zbbb - 4.0*zaaa*zccc,0.0) ) 
    298                   t_i(ji,jj,jk,jl) = rtt + zindb *( - zbbb - zdiscrim ) / &  
    299                      ( 2.0 *zaaa ) 
    300                   t_i(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_i(ji,jj,jk,jl) ) ) 
     216                  zdiscrim   =  SQRT( MAX(zbbb*zbbb - 4._wp*zaaa*zccc , 0._wp) ) 
     217                  t_i(ji,jj,jk,jl) = rtt + zindb *( - zbbb - zdiscrim ) / ( 2.0 *zaaa ) 
     218                  t_i(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15_wp, t_i(ji,jj,jk,jl) ) )       ! 100-rtt < t_i < rtt 
    301219               END DO 
    302220            END DO 
    … …  
    307225      ! Snow temperatures 
    308226      !-------------------- 
    309       zfac1 = 1. / ( rhosn * cpic ) 
     227      zfac1 = 1._wp / ( rhosn * cpic ) 
    310228      zfac2 = lfus / cpic   
    311 !CDIR NOVERRCHK 
    312229      DO jl = 1, jpl 
    313 !CDIR NOVERRCHK 
    314230         DO jk = 1, nlay_s 
    315 !CDIR NOVERRCHK 
    316             DO jj = 1, jpj 
    317 !CDIR NOVERRCHK 
     231            DO jj = 1, jpj 
    318232               DO ji = 1, jpi 
    319233                  !Energy of melting q(S,T) [J.m-3] 
    320                   zq_s       = e_s(ji,jj,jk,jl) / area(ji,jj) / & 
    321                      MAX( v_s(ji,jj,jl) , epsi06 ) * nlay_s  
    322                   ! zindb = 0 if no ice and 1 if yes 
    323                   zindb      = 1.0 - MAX( 0.0 , SIGN( 1.0 , - v_s(ji,jj,jl) ) ) 
    324                   !convert units ! very important that this line is here 
    325                   zq_s       = zq_s * unit_fac * zindb 
     234                  zq_s  = e_s(ji,jj,jk,jl) / ( area(ji,jj) * MAX( v_s(ji,jj,jl) , eps06 ) ) * REAL(nlay_s,wp) 
     235                  zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - v_s(ji,jj,jl) ) )     ! zindb = 0 if no ice and 1 if yes 
     236                  zq_s  = zq_s * unit_fac * zindb                                    ! convert units 
     237                  ! 
    326238                  t_s(ji,jj,jk,jl) = rtt + zindb * ( - zfac1 * zq_s + zfac2 ) 
    327                   t_s(ji,jj,jk,jl) = MIN( rtt, MAX(173.15, t_s(ji,jj,jk,jl) ) ) 
    328  
     239                  t_s(ji,jj,jk,jl) = MIN( rtt, MAX( 173.15, t_s(ji,jj,jk,jl) ) )     ! 100-rtt < t_i < rtt 
    329240               END DO 
    330241            END DO 
    … …  
    335246      ! Mean temperature 
    336247      !------------------- 
    337       tm_i(:,:) = 0.0 
    338 !CDIR NOVERRCHK 
     248      tm_i(:,:) = 0._wp 
    339249      DO jl = 1, jpl 
    340 !CDIR NOVERRCHK 
    341250         DO jk = 1, nlay_i 
    342 !CDIR NOVERRCHK 
    343             DO jj = 1, jpj 
    344 !CDIR NOVERRCHK 
    345                DO ji = 1, jpi 
    346                   zindb          = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) 
    347                   zindb          = zindb*1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) 
    348                   tm_i(ji,jj) = tm_i(ji,jj) + t_i(ji,jj,jk,jl)*v_i(ji,jj,jl) / & 
    349                      REAL(nlay_i) / MAX( vt_i(ji,jj) , zeps ) 
    350                END DO 
    351             END DO 
    352          END DO 
    353       END DO 
    354  
     251            DO jj = 1, jpj 
     252               DO ji = 1, jpi 
     253                  zindb = (  1._wp - MAX( 0._wp , SIGN( 1._wp , -a_i(ji,jj,jl) ) )  )   & 
     254                     &  * (  1._wp - MAX( 0._wp , SIGN( 1._wp , -v_i(ji,jj,jl) ) )  ) 
     255                  tm_i(ji,jj) = tm_i(ji,jj) + t_i(ji,jj,jk,jl) * v_i(ji,jj,jl)   & 
     256                     &                      / (  REAL(nlay_i,wp) * MAX( vt_i(ji,jj) , eps10 )  ) 
     257               END DO 
     258            END DO 
     259         END DO 
     260      END DO 
     261      ! 
    355262   END SUBROUTINE lim_var_glo2eqv 
    356263 
    357    !=============================================================================== 
    358264 
    359265   SUBROUTINE lim_var_eqv2glo 
    360266      !!------------------------------------------------------------------ 
    361       !!                ***  ROUTINE lim_var_eqv2glo ***' 
    362       !! ** Purpose : 
    363       !!        This routine computes global     variables as function of     
    364       !!                              equivalent variables 
    365       !!        i.e. it turns VEQV into VGLO 
     267      !!                ***  ROUTINE lim_var_eqv2glo *** 
     268      !! 
     269      !! ** Purpose :   computes global variables as function of equivalent variables 
     270      !!                i.e. it turns VEQV into VGLO 
    366271      !! ** Method  : 
    367272      !! 
    368       !! ** Arguments : 
    369       !! 
    370       !! ** Inputs / Ouputs : (global commons) 
    371       !! 
    372       !! ** External :  
    373       !! 
    374       !! ** References : 
    375       !! 
    376       !! ** History : 
    377       !!           (01-2006) Martin Vancoppenolle, UCL-ASTR 
    378       !!                     Take it easy man 
    379       !!                     Life is just a simple game, between  
    380       !!                     ups / and downs \ :@) 
    381       !! 
    382       !!------------------------------------------------------------------ 
    383  
     273      !! ** History :  (01-2006) Martin Vancoppenolle, UCL-ASTR 
     274      !!------------------------------------------------------------------ 
     275      ! 
    384276      v_i(:,:,:)   = ht_i(:,:,:) * a_i(:,:,:) 
    385277      v_s(:,:,:)   = ht_s(:,:,:) * a_i(:,:,:) 
    386278      smv_i(:,:,:) = sm_i(:,:,:) * v_i(:,:,:) 
    387279      oa_i (:,:,:) = o_i (:,:,:) * a_i(:,:,:) 
    388  
     280      ! 
    389281   END SUBROUTINE lim_var_eqv2glo 
    390282 
    391    !=============================================================================== 
    392283 
    393284   SUBROUTINE lim_var_salprof 
    394285      !!------------------------------------------------------------------ 
    395       !!                ***  ROUTINE lim_var_salprof ***' 
    396       !! ** Purpose : 
    397       !!        This routine computes salinity profile in function of 
    398       !!        bulk salinity      
     286      !!                ***  ROUTINE lim_var_salprof *** 
     287      !! 
     288      !! ** Purpose :   computes salinity profile in function of bulk salinity      
    399289      !! 
    400290      !! ** Method  : If bulk salinity greater than s_i_1,  
    … …  
    406296      !! 
    407297      !! ** References : Vancoppenolle et al., 2007 (in preparation) 
    408       !! 
    409       !! ** History : 
    410       !!           (08-2006) Martin Vancoppenolle, UCL-ASTR 
    411       !!                     Take it easy man 
    412       !!                     Life is just a simple game, between ups  
    413       !!                     / and downs \ :@) 
    414       !! 
    415       !!------------------------------------------------------------------ 
    416       !! * Arguments 
    417  
    418       !! * Local variables 
    419       INTEGER ::             & 
    420          ji            ,     & !: spatial dummy loop index 
    421          jj            ,     & !: spatial dummy loop index 
    422          jk            ,     & !: vertical layering dummy loop index 
    423          jl                    !: ice category dummy loop index 
    424  
    425       REAL(wp) ::            & 
    426          dummy_fac0    ,     & !: dummy factor used in computations 
    427          dummy_fac1    ,     & !: dummy factor used in computations 
    428          dummy_fac     ,     & !: dummy factor used in computations 
    429          zind0         ,     & !: switch, = 1 if sm_i lt s_i_0 
    430          zind01        ,     & !: switch, = 1 if sm_i between s_i_0 and s_i_1 
    431          zindbal       ,     & !: switch, = 1, if 2*sm_i gt sss_m 
    432          zargtemp              !: dummy factor 
    433  
    434       REAL(wp), DIMENSION(nlay_i) ::      & 
    435          zs_zero               !: linear salinity profile for salinities under 
    436       !: s_i_0 
    437  
    438       REAL(wp), DIMENSION(jpi,jpj,jpl) :: & 
    439          z_slope_s     ,     & !: slope of the salinity profile 
    440          zalpha                !: weight factor for s between s_i_0 and s_i_1 
    441  
    442       !!-- End of declarations 
    443       !!------------------------------------------------------------------------------ 
     298      !!------------------------------------------------------------------ 
     299      INTEGER  ::   ji, jj, jk, jl   ! dummy loop index 
     300      REAL(wp) ::   dummy_fac0, dummy_fac1, dummy_fac, zsal      ! local scalar 
     301      REAL(wp) ::   zind0, zind01, zindbal, zargtemp , zs_zero   !   -      - 
     302      ! 
     303      REAL(wp), POINTER, DIMENSION(:,:,:) ::   z_slope_s, zalpha   ! 3D pointer 
     304      !!------------------------------------------------------------------ 
     305 
     306      IF( .NOT.wrk_use( 2, 1,2 ) ) THEN 
     307         CALL ctl_stop( 'lim_var_salprof : requested workspace arrays unavailable.' )   ;   RETURN 
     308      END IF 
     309 
     310      z_slope_s => wrk_3d_1(:,:,1:jpl)   ! slope of the salinity profile 
     311      zalpha    => wrk_3d_2(:,:,1:jpl)   ! weight factor for s between s_i_0 and s_i_1 
    444312 
    445313      !--------------------------------------- 
    446314      ! Vertically constant, constant in time 
    447315      !--------------------------------------- 
    448  
    449       IF ( num_sal .EQ. 1 ) THEN 
    450  
    451          s_i(:,:,:,:) = bulk_sal 
    452  
    453       ENDIF 
     316      IF( num_sal == 1 )   s_i(:,:,:,:) = bulk_sal 
    454317 
    455318      !----------------------------------- 
    … …  
    457320      !----------------------------------- 
    458321 
    459       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) )THEN 
    460  
     322      IF(   num_sal == 2  .OR.   num_sal == 4   ) THEN 
     323         ! 
    461324         DO jk = 1, nlay_i 
    462325            s_i(:,:,jk,:)  = sm_i(:,:,:) 
    463          END DO ! jk 
    464  
    465          ! Slope of the linear profile zs_zero 
    466          !------------------------------------- 
     326         END DO 
     327         ! 
     328         DO jl = 1, jpl                               ! Slope of the linear profile  
     329            DO jj = 1, jpj 
     330               DO ji = 1, jpi 
     331                  z_slope_s(ji,jj,jl) = 2._wp * sm_i(ji,jj,jl) / MAX( 0.01 , ht_i(ji,jj,jl) ) 
     332               END DO 
     333            END DO 
     334         END DO 
     335         ! 
     336         dummy_fac0 = 1._wp / ( s_i_0 - s_i_1 )       ! Weighting factor between zs_zero and zs_inf 
     337         dummy_fac1 = s_i_1 / ( s_i_1 - s_i_0 ) 
     338 
     339         zalpha(:,:,:) = 0._wp 
    467340         DO jl = 1, jpl 
    468341            DO jj = 1, jpj 
    469                DO ji = 1, jpi 
    470                   z_slope_s(ji,jj,jl) = 2.0 * sm_i(ji,jj,jl) / MAX( 0.01      & 
    471                      , ht_i(ji,jj,jl) ) 
    472                END DO ! ji 
    473             END DO ! jj 
    474          END DO ! jl 
    475  
    476          ! Weighting factor between zs_zero and zs_inf 
    477          !--------------------------------------------- 
    478          dummy_fac0 = 1. / ( ( s_i_0 - s_i_1 ) ) 
    479          dummy_fac1 = s_i_1 / ( s_i_1 - s_i_0 ) 
    480  
    481          zalpha(:,:,:) = 0.0 
    482  
    483 !CDIR NOVERRCHK 
    484          DO jl = 1, jpl 
    485 !CDIR NOVERRCHK 
    486             DO jj = 1, jpj 
    487 !CDIR NOVERRCHK 
    488342               DO ji = 1, jpi 
    489343                  ! zind0 = 1 if sm_i le s_i_0 and 0 otherwise 
    490344                  zind0  = MAX( 0.0   , SIGN( 1.0  , s_i_0 - sm_i(ji,jj,jl) ) )  
    491345                  ! zind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws  
    492                   zind01 = ( 1.0 - zind0 ) *                                  & 
    493                      MAX( 0.0   , SIGN( 1.0  , s_i_1 - sm_i(ji,jj,jl) ) )  
     346                  zind01 = ( 1.0 - zind0 ) * MAX( 0.0   , SIGN( 1.0  , s_i_1 - sm_i(ji,jj,jl) ) )  
    494347                  ! If 2.sm_i GE sss_m then zindbal = 1 
    495                   zindbal = MAX( 0.0 , SIGN( 1.0 , 2. * sm_i(ji,jj,jl) -      & 
    496                      sss_m(ji,jj) ) ) 
    497                   zalpha(ji,jj,jl) = zind0  * 1.0                             & 
    498                      + zind01 * ( sm_i(ji,jj,jl) * dummy_fac0 + & 
    499                      dummy_fac1 ) 
     348                  zindbal = MAX( 0.0 , SIGN( 1.0 , 2. * sm_i(ji,jj,jl) - sss_m(ji,jj) ) ) 
     349                  zalpha(ji,jj,jl) = zind0  * 1.0 + zind01 * ( sm_i(ji,jj,jl) * dummy_fac0 + dummy_fac1 ) 
    500350                  zalpha(ji,jj,jl) = zalpha(ji,jj,jl) * ( 1.0 - zindbal ) 
    501351               END DO 
    … …  
    503353         END DO 
    504354 
    505          ! Computation of the profile 
    506          !---------------------------- 
    507          dummy_fac = 1. / nlay_i 
    508  
     355         dummy_fac = 1._wp / nlay_i                   ! Computation of the profile 
    509356         DO jl = 1, jpl 
    510357            DO jk = 1, nlay_i 
    511358               DO jj = 1, jpj 
    512359                  DO ji = 1, jpi 
    513                      ! linear profile with 0 at the surface 
    514                      zs_zero(jk)      = z_slope_s(ji,jj,jl) * ( jk - 1./2. ) * & 
    515                         ht_i(ji,jj,jl) * dummy_fac 
    516                      ! weighting the profile 
    517                      s_i(ji,jj,jk,jl) = zalpha(ji,jj,jl) * zs_zero(jk) +       & 
    518                         ( 1.0 - zalpha(ji,jj,jl) ) * sm_i(ji,jj,jl) 
     360                     !                                      ! linear profile with 0 at the surface 
     361                     zs_zero = z_slope_s(ji,jj,jl) * ( REAL(jk,wp) - 0.5_wp ) * ht_i(ji,jj,jl) * dummy_fac 
     362                     !                                      ! weighting the profile 
     363                     s_i(ji,jj,jk,jl) = zalpha(ji,jj,jl) * zs_zero + ( 1._wp - zalpha(ji,jj,jl) ) * sm_i(ji,jj,jl) 
    519364                  END DO ! ji 
    520365               END DO ! jj 
    … …  
    527372      ! Vertically varying salinity profile, constant in time 
    528373      !------------------------------------------------------- 
    529       ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
    530  
    531       IF ( num_sal .EQ. 3 ) THEN 
    532  
    533          sm_i(:,:,:) = 2.30 
    534  
    535 !CDIR NOVERRCHK 
     374 
     375      IF( num_sal == 3 ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
     376         ! 
     377         sm_i(:,:,:) = 2.30_wp 
     378         ! 
    536379         DO jl = 1, jpl 
    537380!CDIR NOVERRCHK 
    538381            DO jk = 1, nlay_i 
    539 !CDIR NOVERRCHK 
    540                DO jj = 1, jpj 
    541 !CDIR NOVERRCHK 
    542                   DO ji = 1, jpi 
    543                      zargtemp  = ( jk - 0.5 ) / nlay_i 
    544                      s_i(ji,jj,jk,jl) =  1.6 - 1.6 * COS( 3.14169265 * & 
    545                         ( zargtemp**(0.407/           & 
    546                         ( 0.573 + zargtemp ) ) ) ) 
    547                   END DO ! ji 
    548                END DO ! jj 
    549             END DO ! jk 
    550          END DO ! jl 
     382               zargtemp  = ( REAL(jk,wp) - 0.5_wp ) / REAL(nlay_i,wp) 
     383               zsal =  1.6_wp * (  1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) )  ) 
     384               s_i(:,:,jk,jl) =  zsal 
     385            END DO 
     386         END DO 
    551387 
    552388      ENDIF ! num_sal 
    553  
     389      ! 
     390      IF( .NOT.wrk_release( 2, 1,2 ) )   CALL ctl_stop('lim_var_salprof : failed to release workspace arrays.') 
     391      ! 
    554392   END SUBROUTINE lim_var_salprof 
    555393 
    556    !=============================================================================== 
    557394 
    558395   SUBROUTINE lim_var_bv 
    559396      !!------------------------------------------------------------------ 
    560       !!                ***  ROUTINE lim_var_bv ***' 
    561       !! ** Purpose : 
    562       !!        This routine computes mean brine volume (%) in sea ice 
     397      !!                ***  ROUTINE lim_var_bv *** 
     398      !! 
     399      !! ** Purpose :  computes mean brine volume (%) in sea ice 
    563400      !! 
    564401      !! ** Method  : e = - 0.054 * S (ppt) / T (C) 
    565402      !! 
    566       !! ** Arguments : 
    567       !! 
    568       !! ** Inputs / Ouputs : (global commons) 
    569       !! 
    570       !! ** External :  
    571       !! 
    572       !! ** References : Vancoppenolle et al., JGR, 2007 
    573       !! 
    574       !! ** History : 
    575       !!           (08-2006) Martin Vancoppenolle, UCL-ASTR 
    576       !! 
    577       !!------------------------------------------------------------------ 
    578       !! * Arguments 
    579  
    580       !! * Local variables 
    581       INTEGER ::   ji,       &   ! spatial dummy loop index 
    582          jj,       &   ! spatial dummy loop index 
    583          jk,       &   ! vertical layering dummy loop index 
    584          jl            ! ice category dummy loop index 
    585  
    586       REAL :: zbvi,          &   ! brine volume for a single ice category 
    587          zeps,          &   ! very small value 
    588          zindb              ! is there ice or not 
    589  
    590       !!-- End of declarations 
    591       !!------------------------------------------------------------------------------ 
    592  
    593       zeps = 1.0e-13 
    594       bv_i(:,:) = 0.0 
    595 !CDIR NOVERRCHK 
     403      !! References : Vancoppenolle et al., JGR, 2007 
     404      !!------------------------------------------------------------------ 
     405      INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
     406      REAL(wp) ::   zbvi, zindb      ! local scalars 
     407      !!------------------------------------------------------------------ 
     408      ! 
     409      bv_i(:,:) = 0._wp 
    596410      DO jl = 1, jpl 
    597 !CDIR NOVERRCHK 
    598411         DO jk = 1, nlay_i 
    599 !CDIR NOVERRCHK 
    600             DO jj = 1, jpj 
    601 !CDIR NOVERRCHK 
    602                DO ji = 1, jpi 
    603                   zindb          = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 
    604                   zbvi = - zindb * tmut *s_i(ji,jj,jk,jl) /             &  
    605                      MIN( t_i(ji,jj,jk,jl) - 273.15 , zeps )         & 
    606                      * v_i(ji,jj,jl) / REAL(nlay_i) 
    607                   bv_i(ji,jj) = bv_i(ji,jj) + zbvi  & 
    608                      / MAX( vt_i(ji,jj) , zeps ) 
    609                END DO 
    610             END DO 
    611          END DO 
    612       END DO 
    613  
     412            DO jj = 1, jpj 
     413               DO ji = 1, jpi 
     414                  zindb = 1.0-MAX(0.0,SIGN(1.0,-a_i(ji,jj,jl))) !0 if no ice and 1 if yes 
     415                  zbvi  = - zindb * tmut * s_i(ji,jj,jk,jl) / MIN( t_i(ji,jj,jk,jl) - 273.15 , eps13 )   & 
     416                     &                   * v_i(ji,jj,jl)    / REAL(nlay_i,wp) 
     417                  bv_i(ji,jj) = bv_i(ji,jj) + zbvi  / MAX( vt_i(ji,jj) , eps13 ) 
     418               END DO 
     419            END DO 
     420         END DO 
     421      END DO 
     422      ! 
    614423   END SUBROUTINE lim_var_bv 
    615424 
    616    !=============================================================================== 
    617  
    618    SUBROUTINE lim_var_salprof1d(kideb,kiut) 
     425 
     426   SUBROUTINE lim_var_salprof1d( kideb, kiut ) 
    619427      !!------------------------------------------------------------------- 
    620428      !!                  ***  ROUTINE lim_thd_salprof1d  *** 
    621429      !! 
    622430      !! ** Purpose :   1d computation of the sea ice salinity profile 
    623       !!                Works with 1d vectors and is used by thermodynamic 
    624       !!                modules 
    625       !! 
    626       !! history : 
    627       !!   3.0  !  May  2007 M. Vancoppenolle  Original code 
     431      !!                Works with 1d vectors and is used by thermodynamic modules 
    628432      !!------------------------------------------------------------------- 
    629       INTEGER, INTENT(in) :: & 
    630          kideb, kiut             ! thickness category index 
    631  
    632       INTEGER ::             & 
    633          ji, jk,             &   ! geographic and layer index  
    634          zji, zjj 
    635  
    636       REAL(wp) ::            & 
    637          dummy_fac0,         &   ! dummy factors 
    638          dummy_fac1,         & 
    639          dummy_fac2,         & 
    640          zalpha    ,         &   ! weighting factor 
    641          zind0     ,         &   ! switches as in limvar 
    642          zind01    ,         &   ! switch 
    643          zindbal   ,         &   ! switch if in freshwater area 
    644          zargtemp 
    645  
    646       REAL(wp), DIMENSION(jpij) ::            & 
    647          z_slope_s 
    648  
    649       REAL(wp), DIMENSION(jpij,jkmax) ::      & 
    650          zs_zero 
    651       !!------------------------------------------------------------------- 
     433      INTEGER, INTENT(in) ::   kideb, kiut   ! thickness category index 
     434      ! 
     435      INTEGER  ::   ji, jk    ! dummy loop indices 
     436      INTEGER  ::   zji, zjj  ! local integers 
     437      REAL(wp) ::   dummy_fac0, dummy_fac1, dummy_fac2, zargtemp, zsal   ! local scalars 
     438      REAL(wp) ::   zalpha, zind0, zind01, zindbal, zs_zero              !   -      - 
     439      ! 
     440      REAL(wp), POINTER, DIMENSION(:) ::   z_slope_s 
     441      !!--------------------------------------------------------------------- 
     442 
     443      IF(  .NOT. wrk_use(1, 1)  ) THEN 
     444         CALL ctl_stop('lim_var_salprof1d : requestead workspace arrays unavailable.')   ;   RETURN 
     445      END IF 
     446      ! Set-up pointers to sub-arrays of workspace arrays 
     447      z_slope_s  =>  wrk_1d_1 (1:jpij) 
    652448 
    653449      !--------------------------------------- 
    654450      ! Vertically constant, constant in time 
    655451      !--------------------------------------- 
    656  
    657       IF ( num_sal .EQ. 1 ) THEN 
    658  
    659          s_i_b(:,:) = bulk_sal 
    660  
    661       ENDIF 
     452      IF( num_sal == 1 )   s_i_b(:,:) = bulk_sal 
    662453 
    663454      !------------------------------------------------------ 
    … …  
    665456      !------------------------------------------------------ 
    666457 
    667       IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN 
    668  
    669          ! Slope of the linear profile zs_zero 
    670          !------------------------------------- 
    671 !CDIR NOVERRCHK 
    672          DO ji = kideb, kiut  
    673             z_slope_s(ji) = 2.0 * sm_i_b(ji) / MAX( 0.01      & 
    674                , ht_i_b(ji) ) 
    675          END DO ! ji 
     458      IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN 
     459         ! 
     460         DO ji = kideb, kiut          ! Slope of the linear profile zs_zero 
     461            z_slope_s(ji) = 2._wp * sm_i_b(ji) / MAX( 0.01 , ht_i_b(ji) ) 
     462         END DO 
    676463 
    677464         ! Weighting factor between zs_zero and zs_inf 
    678465         !--------------------------------------------- 
    679          dummy_fac0 = 1. / ( ( s_i_0 - s_i_1 ) ) 
     466         dummy_fac0 = 1._wp / ( s_i_0 - s_i_1 ) 
    680467         dummy_fac1 = s_i_1 / ( s_i_1 - s_i_0 ) 
    681          dummy_fac2 = 1. / nlay_i 
     468         dummy_fac2 = 1._wp / REAL(nlay_i,wp) 
    682469 
    683470!CDIR NOVERRCHK 
    … …  
    685472!CDIR NOVERRCHK 
    686473            DO ji = kideb, kiut 
    687                zji    =  MOD( npb(ji) - 1, jpi ) + 1 
    688                zjj    =  ( npb(ji) - 1 ) / jpi + 1 
    689                zalpha = 0.0 
     474               zji =  MOD( npb(ji) - 1 , jpi ) + 1 
     475               zjj =     ( npb(ji) - 1 ) / jpi + 1 
    690476               ! zind0 = 1 if sm_i le s_i_0 and 0 otherwise 
    691                zind0  = MAX( 0.0   , SIGN( 1.0  , s_i_0 - sm_i_b(ji) ) )  
     477               zind0  = MAX( 0._wp , SIGN( 1._wp  , s_i_0 - sm_i_b(ji) ) )  
    692478               ! zind01 = 1 if sm_i is between s_i_0 and s_i_1 and 0 othws  
    693                zind01 = ( 1.0 - zind0 ) *                                  & 
    694                   MAX( 0.0   , SIGN( 1.0  , s_i_1 - sm_i_b(ji) ) )  
     479               zind01 = ( 1._wp - zind0 ) * MAX( 0._wp , SIGN( 1._wp , s_i_1 - sm_i_b(ji) ) )  
    695480               ! if 2.sm_i GE sss_m then zindbal = 1 
    696                zindbal = MAX( 0.0 , SIGN( 1.0 , 2. * sm_i_b(ji) -      & 
    697                   sss_m(zji,zjj) ) ) 
    698  
    699                zalpha = zind0  * 1.0                                       & 
    700                   + zind01 * ( sm_i_b(ji) * dummy_fac0 +           & 
    701                   dummy_fac1 ) 
    702                zalpha = zalpha * ( 1.0 - zindbal ) 
    703  
    704                zs_zero(ji,jk) = z_slope_s(ji) * ( jk - 1./2. ) * & 
    705                   ht_i_b(ji) * dummy_fac2 
     481               zindbal = MAX( 0._wp , SIGN( 1._wp , 2._wp * sm_i_b(ji) - sss_m(zji,zjj) ) ) 
     482               ! 
     483               zalpha = (  zind0 + zind01 * ( sm_i_b(ji) * dummy_fac0 + dummy_fac1 )  ) * ( 1.0 - zindbal ) 
     484               ! 
     485               zs_zero = z_slope_s(ji) * ( REAL(jk,wp) - 0.5_wp ) * ht_i_b(ji) * dummy_fac2 
    706486               ! weighting the profile 
    707                s_i_b(ji,jk) = zalpha * zs_zero(ji,jk) +       & 
    708                   ( 1.0 - zalpha ) * sm_i_b(ji) 
     487               s_i_b(ji,jk) = zalpha * zs_zero + ( 1._wp - zalpha ) * sm_i_b(ji) 
    709488            END DO ! ji 
    710489         END DO ! jk 
    … …  
    715494      ! Vertically varying salinity profile, constant in time 
    716495      !------------------------------------------------------- 
    717       ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
    718  
    719       IF ( num_sal .EQ. 3 ) THEN 
    720  
    721          sm_i_b(:) = 2.30 
    722  
    723 !CDIR NOVERRCHK 
    724          DO ji = kideb, kiut 
    725 !CDIR NOVERRCHK 
    726             DO jk = 1, nlay_i 
    727                zargtemp  = ( jk - 0.5 ) / nlay_i 
    728                s_i_b(ji,jk)  =  1.6 - 1.6*cos(3.14169265*(zargtemp**(0.407/ & 
    729                   (0.573+zargtemp)))) 
    730             END DO ! jk 
    731          END DO ! ji 
    732  
    733       ENDIF ! num_sal 
    734  
     496 
     497      IF( num_sal == 3 ) THEN      ! Schwarzacher (1959) multiyear salinity profile (mean = 2.30) 
     498         ! 
     499         sm_i_b(:) = 2.30_wp 
     500         ! 
     501!CDIR NOVERRCHK 
     502         DO jk = 1, nlay_i 
     503            zargtemp  = ( REAL(jk,wp) - 0.5_wp ) / REAL(nlay_i,wp) 
     504            zsal =  1.6_wp * (  1._wp - COS( rpi * zargtemp**(0.407_wp/(0.573_wp+zargtemp)) )  ) 
     505            DO ji = kideb, kiut 
     506               s_i_b(ji,jk) = zsal 
     507            END DO 
     508         END DO 
     509         ! 
     510      ENDIF 
     511      ! 
     512      IF( .NOT. wrk_release(1, 1) )   CALL ctl_stop( 'lim_var_salprof1d : failed to release workspace arrays.' ) 
     513      ! 
    735514   END SUBROUTINE lim_var_salprof1d 
    736515 
    737    !=============================================================================== 
    738  
    739516#else 
    740    !!====================================================================== 
    741    !!                       ***  MODULE limvar  *** 
    742    !!                          no sea ice model 
    743    !!====================================================================== 
     517   !!---------------------------------------------------------------------- 
     518   !!   Default option         Dummy module          NO  LIM3 sea-ice model 
     519   !!---------------------------------------------------------------------- 
    744520CONTAINS 
    745521   SUBROUTINE lim_var_agg          ! Empty routines 
    … …  
    755531   SUBROUTINE lim_var_salprof1d    ! Emtpy routines 
    756532   END SUBROUTINE lim_var_salprof1d 
    757  
    758533#endif 
     534 
     535   !!====================================================================== 
    759536END MODULE limvar 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limwri.F90

    r2601 r2612  
    198198 
    199199      !-- calculs des valeurs instantanees 
    200       zcmo ( 1:jpi, 1:jpj, 1:jpnoumax ) = 0.0  
    201       zcmoa( 1:jpi, 1:jpj, 1:jpnoumax ) = 0.0  
     200      zcmo ( 1:jpi, 1:jpj, 1:jpnoumax ) = 0._wp 
     201      zcmoa( 1:jpi, 1:jpj, 1:jpnoumax ) = 0._wp 
    202202 
    203203      DO jl = 1, jpl 
    … …  
    222222 
    223223            zcmo(ji,jj,1)  = at_i(ji,jj) 
    224             zcmo(ji,jj,2)  = vt_i(ji,jj)/MAX(at_i(ji,jj),epsi16)*zinda 
    225             zcmo(ji,jj,3)  = vt_s(ji,jj)/MAX(at_i(ji,jj),epsi16)*zinda 
    226             zcmo(ji,jj,4)  = diag_bot_gr(ji,jj) * & 
    227                86400.0 * zinda !Bottom thermodynamic ice production 
    228             zcmo(ji,jj,5)  = diag_dyn_gr(ji,jj) * & 
    229                86400.0 * zinda !Dynamic ice production (rid/raft) 
    230             zcmo(ji,jj,22) = diag_lat_gr(ji,jj) * & 
    231                86400.0 * zinda !Lateral thermodynamic ice production 
    232             zcmo(ji,jj,23) = diag_sni_gr(ji,jj) * & 
    233                86400.0 * zinda !Snow ice production ice production 
     224            zcmo(ji,jj,2)  = vt_i(ji,jj) / MAX( at_i(ji,jj), epsi16 ) * zinda 
     225            zcmo(ji,jj,3)  = vt_s(ji,jj) / MAX( at_i(ji,jj), epsi16 ) * zinda 
     226            zcmo(ji,jj,4)  = diag_bot_gr(ji,jj) * 86400.0 * zinda    ! Bottom thermodynamic ice production 
     227            zcmo(ji,jj,5)  = diag_dyn_gr(ji,jj) * 86400.0 * zinda    ! Dynamic ice production (rid/raft) 
     228            zcmo(ji,jj,22) = diag_lat_gr(ji,jj) * 86400.0 * zinda    ! Lateral thermodynamic ice production 
     229            zcmo(ji,jj,23) = diag_sni_gr(ji,jj) * 86400.0 * zinda    ! Snow ice production ice production 
    234230            zcmo(ji,jj,24) = tm_i(ji,jj) - rtt 
    235231 
    236232            zcmo(ji,jj,6)  = fbif  (ji,jj) 
    237             zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj  ) * tmu(ji,jj)        & 
    238                &                                + u_ice(ji-1,jj) * tmu(ji-1,jj) )    & 
    239                &                     / 2.0  
    240             zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj  ) * tmv(ji,jj)        & 
    241                &                                + v_ice(ji,jj-1) * tmv(ji,jj-1) )    & 
    242                &                     / 2.0 
     233            zcmo(ji,jj,7)  = zindb * (  u_ice(ji,jj) * tmu(ji,jj) + u_ice(ji-1,jj) * tmu(ji-1,jj) ) * 0.5_wp 
     234            zcmo(ji,jj,8)  = zindb * (  v_ice(ji,jj) * tmv(ji,jj) + v_ice(ji,jj-1) * tmv(ji,jj-1) ) * 0.5_wp 
    243235            zcmo(ji,jj,9)  = sst_m(ji,jj) 
    244236            zcmo(ji,jj,10) = sss_m(ji,jj) 
    … …  
    250242            zcmo(ji,jj,15) = utau_ice(ji,jj) 
    251243            zcmo(ji,jj,16) = vtau_ice(ji,jj) 
    252             zcmo(ji,jj,17) = zcmo(ji,jj,17) + (1.0-at_i(ji,jj))*qsr(ji,jj) 
    253             zcmo(ji,jj,18) = zcmo(ji,jj,18) + (1.0-at_i(ji,jj))*qns(ji,jj) 
     244            zcmo(ji,jj,17) = zcmo(ji,jj,17) + ( 1._wp - at_i(ji,jj) ) * qsr(ji,jj) 
     245            zcmo(ji,jj,18) = zcmo(ji,jj,18) + ( 1._wp - at_i(ji,jj) ) * qns(ji,jj) 
    254246            zcmo(ji,jj,19) = sprecip(ji,jj) 
    255247            zcmo(ji,jj,20) = smt_i(ji,jj) 
    … …  
    263255            zcmo(ji,jj,31) = hicol(ji,jj) 
    264256            zcmo(ji,jj,32) = strength(ji,jj) 
    265             zcmo(ji,jj,33) = SQRT( zcmo(ji,jj,7)*zcmo(ji,jj,7) + & 
    266                zcmo(ji,jj,8)*zcmo(ji,jj,8) ) 
    267             zcmo(ji,jj,34) = diag_sur_me(ji,jj) * & 
    268                86400.0 * zinda ! Surface melt 
    269             zcmo(ji,jj,35) = diag_bot_me(ji,jj) * & 
    270                86400.0 * zinda ! Bottom melt 
     257            zcmo(ji,jj,33) = SQRT(  zcmo(ji,jj,7)*zcmo(ji,jj,7) + zcmo(ji,jj,8)*zcmo(ji,jj,8)  ) 
     258            zcmo(ji,jj,34) = diag_sur_me(ji,jj) * 86400.0 * zinda    ! Surface melt 
     259            zcmo(ji,jj,35) = diag_bot_me(ji,jj) * 86400.0 * zinda    ! Bottom melt 
    271260            zcmo(ji,jj,36) = divu_i(ji,jj) 
    272261            zcmo(ji,jj,37) = shear_i(ji,jj) 
    … …  
    279268      niter = niter + 1 
    280269      DO jf = 1 , noumef 
    281          DO jj = 1 , jpj 
    282             DO ji = 1 , jpi 
    283                zfield(ji,jj) = zcmo(ji,jj,jf) * cmulti(jf) + cadd(jf) 
    284             END DO 
    285          END DO 
    286  
    287          IF ( jf == 7  .OR. jf == 8  .OR. jf == 15 .OR. jf == 16 ) THEN  
    288             CALL lbc_lnk( zfield, 'T', -1. ) 
    289          ELSE  
    290             CALL lbc_lnk( zfield, 'T',  1. ) 
     270         ! 
     271         zfield(:,:) = zcmo(:,:,jf) * cmulti(jf) + cadd(jf) 
     272         ! 
     273         IF( jf == 7  .OR. jf == 8  .OR. jf == 15 .OR. jf == 16 ) THEN   ;   CALL lbc_lnk( zfield, 'T', -1. ) 
     274         ELSE                                                            ;   CALL lbc_lnk( zfield, 'T',  1. ) 
    291275         ENDIF 
    292  
     276         ! 
    293277         IF( ln_nicep ) THEN  
    294278            WRITE(numout,*) 
    … …  
    296280            WRITE(numout,*) nc(jf), nice, nam(jf), niter, ndim 
    297281         ENDIF 
    298          IF ( nc(jf) == 1 ) CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 ) 
    299  
     282         IF( nc(jf) == 1 ) CALL histwrite( nice, nam(jf), niter, zfield, ndim, ndex51 ) 
     283         ! 
    300284      END DO 
    301285 
    302       IF ( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 
     286      IF( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 
    303287         IF( lwp) WRITE(numout,*) ' Closing the icemod file ' 
    304288         CALL histclo( nice ) 
    … …  
    308292      ! Thickness distribution file 
    309293      !----------------------------- 
    310       IF ( add_diag_swi .EQ. 1 ) THEN 
     294      IF( add_diag_swi == 1 ) THEN 
    311295 
    312296         DO jl = 1, jpl  
    … …  
    323307               DO ji = 1, jpi 
    324308                  zinda = MAX( zzero , SIGN( zone , a_i(ji,jj,jl) - 1.0e-6 ) ) 
    325                   zoi(ji,jj,jl) = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , 1.0e-6 ) * & 
    326                      zinda 
     309                  zoi(ji,jj,jl) = oa_i(ji,jj,jl)  / MAX( a_i(ji,jj,jl) , 1.0e-6 ) * zinda 
    327310               END DO 
    328311            END DO 
    … …  
    330313 
    331314         ! Compute brine volume 
    332          zei(:,:,:) = 0.0 
     315         zei(:,:,:) = 0._wp 
    333316         DO jl = 1, jpl  
    334317            DO jk = 1, nlay_i 
    … …  
    359342         !     not yet implemented 
    360343 
    361          IF ( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 
     344         IF( ( nn_fsbc * niter ) >= nitend .OR. kindic < 0 ) THEN 
    362345            IF(lwp) WRITE(numout,*) ' Closing the icemod file ' 
    363346            CALL histclo( nicea )  
    364347         ENDIF 
    365  
     348         ! 
    366349      ENDIF 
    367350 
    … …  
    379362      !! 
    380363      !! ** input   :   Namelist namicewri 
    381       !! 
    382       !! history :  8.5  ! 03-08 (C. Ethe) original code 
    383364      !!------------------------------------------------------------------- 
    384365      INTEGER ::   nf      ! ??? 
    … …  
    414395      !!------------------------------------------------------------------- 
    415396 
    416       ! Read Namelist namicewri 
    417       REWIND ( numnam_ice ) 
    418       READ   ( numnam_ice  , namiceout ) 
     397      REWIND( numnam_ice )                ! Read Namelist namicewri 
     398      READ  ( numnam_ice  , namiceout ) 
    419399 
    420400      zfield(1)  = field_1 
    … …  
    465445      END DO 
    466446 
    467       IF(lwp) THEN 
     447      IF(lwp) THEN                        ! control print 
    468448         WRITE(numout,*) 
    469449         WRITE(numout,*) 'lim_wri_init : Ice parameters for outputs' 
    … …  
    473453            &            '    multiplicative constant       additive constant ' 
    474454         DO nf = 1 , noumef          
    475             WRITE(numout,*) '   ', titn(nf), '   ', nam(nf),'      ', uni(nf),'  ', nc(nf),'        ', cmulti(nf),   & 
    476                '        ', cadd(nf) 
     455            WRITE(numout,*) '   ', titn(nf), '   '    , nam   (nf), '      '  , uni (nf),   & 
     456               &            '  ' , nc  (nf),'        ', cmulti(nf), '        ', cadd(nf) 
    477457         END DO 
    478458         WRITE(numout,*) ' add_diag_swi ', add_diag_swi 
    479459      ENDIF 
    480  
     460      ! 
    481461   END SUBROUTINE lim_wri_init 
    482462 

  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/LIM_SRC_3/limwri_dimg.h90

    r2528 r2612  
    1414   !!  modif : 03/06/98 
    1515   !!------------------------------------------------------------------- 
    16    !! * Local variables 
    1716   USE  diawri, ONLY : dia_wri_dimg 
    1817   REAL(wp),DIMENSION(1) ::   zdept 
    1918 
    20    REAL(wp) :: & 
    21       zsto, zsec, zjulian,zout, & 
    22       zindh,zinda,zindb,  & 
    23       ztmu 
    24    REAL(wp), DIMENSION(jpi,jpj,jpnoumax) :: & 
    25       zcmo 
    26    REAL(wp), DIMENSION(jpi,jpj) ::  & 
    27       zfield 
    28    INTEGER, SAVE :: nmoyice, &  !: counter for averaging 
    29       &             nwf         !: number of fields to write on disk 
     19   REAL(wp) ::   zsto, zsec, zjulian,zout, & 
     20   REAL(wp) ::   zindh,zinda,zindb, ztmu 
     21   REAL(wp), DIMENSION(jpi,jpj,jpnoumax) ::   zcmo 
     22   REAL(wp), DIMENSION(jpi,jpj) ::   zfield 
     23   INTEGER, SAVE ::   nmoyice   !: counter for averaging 
     24   INTEGER, SAVE ::   nwf       !: number of fields to write on disk 
    3025   INTEGER, SAVE,DIMENSION (:), ALLOCATABLE  :: nsubindex   !: subindex to be saved 
    3126   ! according to namelist 
    … …  
    4338 
    4439 
    45    INTEGER , SAVE ::      & 
    46       nice, nhorid, ndim, niter, ndepid 
    47    INTEGER , DIMENSION( jpij ) , SAVE ::  & 
    48       ndex51   
     40   INTEGER , SAVE ::   nice, nhorid, ndim, niter, ndepid 
     41   INTEGER , DIMENSION( jpij ) , SAVE ::   ndex51   
    4942   !!------------------------------------------------------------------- 
    5043   IF ( numit == nstart ) THEN  
Note: See TracChangeset for help on using the changeset viewer.