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.
limthd_lac.F90 in trunk/NEMOGCM/NEMO/LIM_SRC_3 – NEMO

source: trunk/NEMOGCM/NEMO/LIM_SRC_3/limthd_lac.F90 @ 2715

Last change on this file since 2715 was 2715, checked in by rblod, 13 years ago

First attempt to put dynamic allocation on the trunk

  • Property svn:keywords set to Id
File size: 31.9 KB
Line 
1MODULE limthd_lac
2   !!======================================================================
3   !!                       ***  MODULE limthd_lac   ***
4   !!                lateral thermodynamic growth of the ice
5   !!======================================================================
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   !!----------------------------------------------------------------------
11#if defined key_lim3
12   !!----------------------------------------------------------------------
13   !!   'key_lim3'                                      LIM3 sea-ice model
14   !!----------------------------------------------------------------------
15   !!   lim_lat_acr    : lateral accretion of ice
16   !!----------------------------------------------------------------------
17   USE par_oce          ! ocean parameters
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
30   USE lib_mpp         ! MPP library
31
32   IMPLICIT NONE
33   PRIVATE
34
35   PUBLIC lim_thd_lac     ! called by lim_thd
36
37   REAL(wp) ::   epsi20 = 1e-20_wp   ! constant values
38   REAL(wp) ::   epsi13 = 1e-13_wp   !
39   REAL(wp) ::   epsi11 = 1e-11_wp   !
40   REAL(wp) ::   epsi10 = 1e-10_wp   !
41   REAL(wp) ::   epsi06 = 1e-06_wp   !
42   REAL(wp) ::   epsi03 = 1e-03_wp   !
43   REAL(wp) ::   zzero  = 0._wp      !
44   REAL(wp) ::   zone   = 1._wp      !
45
46   !!----------------------------------------------------------------------
47   !! NEMO/LIM3 4.0 , UCL - NEMO Consortium (2011)
48   !! $Id$
49   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
50   !!----------------------------------------------------------------------
51CONTAINS
52
53   SUBROUTINE lim_thd_lac
54      !!-------------------------------------------------------------------
55      !!               ***   ROUTINE lim_thd_lac  ***
56      !! 
57      !! ** Purpose : Computation of the evolution of the ice thickness and
58      !!      concentration as a function of the heat balance in the leads.
59      !!      It is only used for lateral accretion
60      !!       
61      !! ** Method  : Ice is formed in the open water when ocean lose heat
62      !!      (heat budget of open water Bl is negative) .
63      !!      Computation of the increase of 1-A (ice concentration) fol-
64      !!      lowing the law :
65      !!      (dA/dt)acc = F[ (1-A)/(1-a) ] * [ Bl / (Li*h0) ]
66      !!       where - h0 is the thickness of ice created in the lead
67      !!             - a is a minimum fraction for leads
68      !!             - F is a monotonic non-increasing function defined as:
69      !!                  F(X)=( 1 - X**exld )**(1.0/exld)
70      !!             - exld is the exponent closure rate (=2 default val.)
71      !!
72      !! ** Action : - Adjustment of snow and ice thicknesses and heat
73      !!                content in brine pockets
74      !!             - Updating ice internal temperature
75      !!             - Computation of variation of ice volume and mass
76      !!             - Computation of frldb after lateral accretion and
77      !!               update ht_s_b, ht_i_b and tbif_1d(:,:)     
78      !!------------------------------------------------------------------------
79      USE wrk_nemo, ONLY :   vt_i_init => wrk_2d_1 , vt_i_final => wrk_2d_4 , et_i_init => wrk_2d_7
80      USE wrk_nemo, ONLY :   vt_s_init => wrk_2d_2 , vt_s_final => wrk_2d_5 , et_s_init => wrk_2d_8
81      USE wrk_nemo, ONLY :   zvrel     => wrk_2d_3 , et_i_final => wrk_2d_6 
82      !
83      INTEGER ::   ji,jj,jk,jl,jm   ! dummy loop indices
84      INTEGER ::   layer, nbpac     ! local integers
85      INTEGER ::   zji, zjj, iter   !   -       -
86      REAL(wp)  ::   ztmelts, zdv, zqold, zfrazb, zweight, zalphai, zindb, zde  ! local scalars
87      REAL(wp) ::   zgamafr, zvfrx, zvgx, ztaux, ztwogp, zf , zhicol_new        !   -      -
88      REAL(wp) ::   ztenagm, zvfry, zvgy, ztauy, zvrel2, zfp, zsqcd , zhicrit   !   -      -
89      LOGICAL  ::   iterate_frazil   ! iterate frazil ice collection thickness
90      CHARACTER (len = 15) :: fieldid
91      !
92      INTEGER, DIMENSION(jpij) ::   zcatac    !  indexes of categories where new ice grows
93
94      REAL(wp), DIMENSION(jpij,jpl) ::   zhice_old   ! previous ice thickness
95      REAL(wp), DIMENSION(jpij,jpl) ::   zdummy      ! dummy thickness of new ice
96      REAL(wp), DIMENSION(jpij,jpl) ::   zdhicbot    ! thickness of new ice which is accreted vertically
97      REAL(wp), DIMENSION(jpij,jpl) ::   zv_old      ! old volume of ice in category jl
98      REAL(wp), DIMENSION(jpij,jpl) ::   za_old      ! old area of ice in category jl
99      REAL(wp), DIMENSION(jpij,jpl) ::   za_i_ac     ! 1-D version of a_i
100      REAL(wp), DIMENSION(jpij,jpl) ::   zv_i_ac     ! 1-D version of v_i
101      REAL(wp), DIMENSION(jpij,jpl) ::   zoa_i_ac    ! 1-D version of oa_i
102      REAL(wp), DIMENSION(jpij,jpl) ::   zsmv_i_ac   ! 1-D version of smv_i
103
104      REAL(wp), DIMENSION(jpij,jkmax  ,jpl) ::   ze_i_ac   !: 1-D version of e_i
105      REAL(wp), DIMENSION(jpij,jkmax+1,jpl) ::   zqm0      ! old layer-system heat content
106      REAL(wp), DIMENSION(jpij,jkmax+1,jpl) ::   zthick0   ! old ice thickness
107
108      REAL(wp), POINTER, DIMENSION(:) ::   zv_newice, zh_newice, zs_newice, zdv_res, zat_i_ac , zdh_frazb, zqbgow
109      REAL(wp), POINTER, DIMENSION(:) ::   za_newice, ze_newice, zo_newice, zda_res, zat_i_lev, zvrel_ac , zdhex
110      REAL(wp), POINTER, DIMENSION(:) ::   zswinew
111      !!-----------------------------------------------------------------------!
112
113      IF(  wrk_in_use(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) .OR.   &
114         & wrk_in_use(2, 1,2,3,4,5,6,7,8)                        ) THEN
115         CALL ctl_stop('lim_thd_dh : requestead workspace arrays unavailable.')   ;   RETURN
116      END IF
117      ! Set-up pointers to sub-arrays of workspace arrays
118      zv_newice =>  wrk_1d_1 (1:jpij)   ! volume of accreted ice
119      za_newice =>  wrk_1d_2 (1:jpij)   ! fractional area of accreted ice
120      zh_newice =>  wrk_1d_3 (1:jpij)   ! thickness of accreted ice
121      ze_newice =>  wrk_1d_4 (1:jpij)   ! heat content of accreted ice
122      zs_newice =>  wrk_1d_5 (1:jpij)   ! salinity of accreted ice
123      zo_newice =>  wrk_1d_6 (1:jpij)   ! age of accreted ice
124      zdv_res   =>  wrk_1d_7 (1:jpij)   ! residual volume in case of excessive heat budget
125      zda_res   =>  wrk_1d_8 (1:jpij)   ! residual area in case of excessive heat budget
126      zat_i_ac  =>  wrk_1d_9 (1:jpij)   ! total ice fraction
127      zat_i_lev =>  wrk_1d_10(1:jpij)   ! total ice fraction for level ice only (type 1)   
128      zdh_frazb =>  wrk_1d_11(1:jpij)   ! accretion of frazil ice at the ice bottom
129      zvrel_ac  =>  wrk_1d_12(1:jpij)   ! relative ice / frazil velocity (1D vector)
130      zqbgow    =>  wrk_1d_13(1:jpij)   ! heat budget of the open water (negative)
131      zdhex     =>  wrk_1d_14(1:jpij)   ! excessively thick accreted sea ice (hlead-hice)
132
133
134
135      et_i_init(:,:) = 0._wp
136      et_s_init(:,:) = 0._wp
137      vt_i_init(:,:) = 0._wp
138      vt_s_init(:,:) = 0._wp
139
140      !------------------------------------------------------------------------------!
141      ! 1) Conservation check and changes in each ice category
142      !------------------------------------------------------------------------------!
143      IF ( con_i ) THEN
144         CALL lim_column_sum (jpl, v_i, vt_i_init)
145         CALL lim_column_sum (jpl, v_s, vt_s_init)
146         CALL lim_column_sum_energy (jpl, nlay_i, e_i, et_i_init)
147         CALL lim_column_sum (jpl,   e_s(:,:,1,:) , et_s_init)
148      ENDIF
149
150      !------------------------------------------------------------------------------|
151      ! 2) Convert units for ice internal energy
152      !------------------------------------------------------------------------------|
153      DO jl = 1, jpl
154         DO jk = 1, nlay_i
155            DO jj = 1, jpj
156               DO ji = 1, jpi
157                  !Energy of melting q(S,T) [J.m-3]
158                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) / &
159                     MAX( area(ji,jj) * v_i(ji,jj,jl) ,  epsi10 ) * &
160                     nlay_i
161                  zindb      = 1.0-MAX(0.0,SIGN(1.0,-v_i(ji,jj,jl))) !0 if no ice and 1 if yes
162                  e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl)*unit_fac*zindb
163               END DO
164            END DO
165         END DO
166      END DO
167
168      !------------------------------------------------------------------------------!
169      ! 3) Collection thickness of ice formed in leads and polynyas
170      !------------------------------------------------------------------------------!   
171      ! hicol is the thickness of new ice formed in open water
172      ! hicol can be either prescribed (frazswi = 0)
173      ! or computed (frazswi = 1)
174      ! Frazil ice forms in open water, is transported by wind
175      ! accumulates at the edge of the consolidated ice edge
176      ! where it forms aggregates of a specific thickness called
177      ! collection thickness.
178
179      ! Note : the following algorithm currently breaks vectorization
180      !
181
182      zvrel(:,:) = 0.0
183
184      ! Default new ice thickness
185      DO jj = 1, jpj
186         DO ji = 1, jpi
187            hicol(ji,jj) = hiccrit(1)
188         END DO
189      END DO
190
191      IF (fraz_swi.eq.1.0) THEN
192
193         !--------------------
194         ! Physical constants
195         !--------------------
196         hicol(:,:) = 0.0
197
198         zhicrit = 0.04 ! frazil ice thickness
199         ztwogp  = 2. * rau0 / ( grav * 0.3 * ( rau0 - rhoic ) ) ! reduced grav
200         zsqcd   = 1.0 / SQRT( 1.3 * cai ) ! 1/SQRT(airdensity*drag)
201         zgamafr = 0.03
202
203         DO jj = 1, jpj
204            DO ji = 1, jpi
205
206               IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) > 0.e0 ) THEN
207                  !-------------
208                  ! Wind stress
209                  !-------------
210                  ! C-grid wind stress components
211                  ztaux         = ( utau_ice(ji-1,jj  ) * tmu(ji-1,jj  ) &
212                     &          +   utau_ice(ji  ,jj  ) * tmu(ji  ,jj  ) ) / 2.0
213                  ztauy         = ( vtau_ice(ji  ,jj-1) * tmv(ji  ,jj-1) &
214                     &          +   vtau_ice(ji  ,jj  ) * tmv(ji  ,jj  ) ) / 2.0
215                  ! Square root of wind stress
216                  ztenagm       =  SQRT( SQRT( ztaux * ztaux + ztauy * ztauy ) )
217
218                  !---------------------
219                  ! Frazil ice velocity
220                  !---------------------
221                  zvfrx         = zgamafr * zsqcd * ztaux / MAX(ztenagm,epsi10)
222                  zvfry         = zgamafr * zsqcd * ztauy / MAX(ztenagm,epsi10)
223
224                  !-------------------
225                  ! Pack ice velocity
226                  !-------------------
227                  ! C-grid ice velocity
228                  zindb = MAX(0.0, SIGN(1.0, at_i(ji,jj) ))
229                  zvgx  = zindb * ( u_ice(ji-1,jj  ) * tmu(ji-1,jj  ) &
230                     + u_ice(ji,jj    ) * tmu(ji  ,jj  ) ) / 2.0
231                  zvgy  = zindb * ( v_ice(ji  ,jj-1) * tmv(ji  ,jj-1) &
232                     + v_ice(ji,jj    ) * tmv(ji  ,jj  ) ) / 2.0
233
234                  !-----------------------------------
235                  ! Relative frazil/pack ice velocity
236                  !-----------------------------------
237                  ! absolute relative velocity
238                  zvrel2        = MAX( ( zvfrx - zvgx ) * ( zvfrx - zvgx ) + &
239                     ( zvfry - zvgy ) * ( zvfry - zvgy )   &
240                     , 0.15 * 0.15 )
241                  zvrel(ji,jj)  = SQRT(zvrel2)
242
243                  !---------------------
244                  ! Iterative procedure
245                  !---------------------
246                  hicol(ji,jj) = zhicrit + 0.1 
247                  hicol(ji,jj) = zhicrit + hicol(ji,jj) /      & 
248                     ( hicol(ji,jj) * hicol(ji,jj) - &
249                     zhicrit * zhicrit ) * ztwogp * zvrel2
250
251                  iter = 1
252                  iterate_frazil = .true.
253
254                  DO WHILE ( iter .LT. 100 .AND. iterate_frazil ) 
255                     zf = ( hicol(ji,jj) - zhicrit ) * ( hicol(ji,jj)**2 - zhicrit**2 ) &
256                        - hicol(ji,jj) * zhicrit * ztwogp * zvrel2
257                     zfp = ( hicol(ji,jj) - zhicrit ) * ( 3.0*hicol(ji,jj) + zhicrit ) &
258                        - zhicrit * ztwogp * zvrel2
259                     zhicol_new = hicol(ji,jj) - zf/zfp
260                     hicol(ji,jj)   = zhicol_new
261
262                     iter = iter + 1
263
264                  END DO ! do while
265
266               ENDIF ! end of selection of pixels where ice forms
267
268            END DO ! loop on ji ends
269         END DO ! loop on jj ends
270
271      ENDIF ! End of computation of frazil ice collection thickness
272
273      !------------------------------------------------------------------------------!
274      ! 4) Identify grid points where new ice forms
275      !------------------------------------------------------------------------------!
276
277      !-------------------------------------
278      ! Select points for new ice formation
279      !-------------------------------------
280      ! This occurs if open water energy budget is negative
281      nbpac = 0
282      DO jj = 1, jpj
283         DO ji = 1, jpi
284            IF ( tms(ji,jj) * ( qcmif(ji,jj) - qldif(ji,jj) ) > 0.e0 ) THEN
285               nbpac = nbpac + 1
286               npac( nbpac ) = (jj - 1) * jpi + ji
287               IF ( (ji.eq.jiindx).AND.(jj.eq.jjindx) ) THEN
288                  jiindex_1d = nbpac
289               ENDIF
290            ENDIF
291         END DO
292      END DO
293
294      IF( ln_nicep ) THEN
295         WRITE(numout,*) 'lim_thd_lac : nbpac = ', nbpac
296      ENDIF
297
298      !------------------------------
299      ! Move from 2-D to 1-D vectors
300      !------------------------------
301      ! If ocean gains heat do nothing
302      ! 0therwise compute new ice formation
303
304      IF ( nbpac > 0 ) THEN
305
306         CALL tab_2d_1d( nbpac, zat_i_ac  (1:nbpac)     , at_i         ,       &
307            jpi, jpj, npac(1:nbpac) )
308         DO jl = 1, jpl
309            CALL tab_2d_1d( nbpac, za_i_ac(1:nbpac,jl)  , a_i(:,:,jl)  ,       &
310               jpi, jpj, npac(1:nbpac) )
311            CALL tab_2d_1d( nbpac, zv_i_ac(1:nbpac,jl)  , v_i(:,:,jl)  ,       &
312               jpi, jpj, npac(1:nbpac) )
313            CALL tab_2d_1d( nbpac, zoa_i_ac(1:nbpac,jl) , oa_i(:,:,jl) ,       &
314               jpi, jpj, npac(1:nbpac) )
315            CALL tab_2d_1d( nbpac, zsmv_i_ac(1:nbpac,jl), smv_i(:,:,jl),       &
316               jpi, jpj, npac(1:nbpac) )
317            DO jk = 1, nlay_i
318               CALL tab_2d_1d( nbpac, ze_i_ac(1:nbpac,jk,jl), e_i(:,:,jk,jl) , &
319                  jpi, jpj, npac(1:nbpac) )
320            END DO ! jk
321         END DO ! jl
322
323         CALL tab_2d_1d( nbpac, qldif_1d  (1:nbpac)     , qldif ,              &
324            jpi, jpj, npac(1:nbpac) )
325         CALL tab_2d_1d( nbpac, qcmif_1d  (1:nbpac)     , qcmif ,              &
326            jpi, jpj, npac(1:nbpac) )
327         CALL tab_2d_1d( nbpac, t_bo_b    (1:nbpac)     , t_bo  ,              &
328            jpi, jpj, npac(1:nbpac) )
329         CALL tab_2d_1d( nbpac, fseqv_1d  (1:nbpac)     , fseqv ,              &
330            jpi, jpj, npac(1:nbpac) )
331         CALL tab_2d_1d( nbpac, hicol_b   (1:nbpac)     , hicol ,              &
332            jpi, jpj, npac(1:nbpac) )
333         CALL tab_2d_1d( nbpac, zvrel_ac  (1:nbpac)     , zvrel ,              &
334            jpi, jpj, npac(1:nbpac) )
335
336         !------------------------------------------------------------------------------!
337         ! 5) Compute thickness, salinity, enthalpy, age, area and volume of new ice
338         !------------------------------------------------------------------------------!
339
340         !----------------------
341         ! Thickness of new ice
342         !----------------------
343         DO ji = 1, nbpac
344            zh_newice(ji)     = hiccrit(1)
345         END DO
346         IF ( fraz_swi .EQ. 1.0 ) zh_newice(:) = hicol_b(:)
347
348         !----------------------
349         ! Salinity of new ice
350         !----------------------
351
352         IF ( num_sal .EQ. 1 ) THEN
353            zs_newice(:)      =   bulk_sal
354         ENDIF ! num_sal
355
356         IF ( ( num_sal .EQ. 2 ) .OR. ( num_sal .EQ. 4 ) ) THEN
357
358            DO ji = 1, nbpac
359               zs_newice(ji)  =   MIN( 4.606 + 0.91 / zh_newice(ji) , s_i_max )
360               zji            =   MOD( npac(ji) - 1, jpi ) + 1
361               zjj            =   ( npac(ji) - 1 ) / jpi + 1
362               zs_newice(ji)  =   MIN( 0.5*sss_m(zji,zjj) , zs_newice(ji) )
363            END DO ! jl
364
365         ENDIF ! num_sal
366
367         IF ( num_sal .EQ. 3 ) THEN
368            zs_newice(:)      =   2.3
369         ENDIF ! num_sal
370
371         !-------------------------
372         ! Heat content of new ice
373         !-------------------------
374         ! We assume that new ice is formed at the seawater freezing point
375         DO ji = 1, nbpac
376            ztmelts           = - tmut * zs_newice(ji) + rtt ! Melting point (K)
377            ze_newice(ji)     =   rhoic * ( cpic * ( ztmelts - t_bo_b(ji) )    &
378               + lfus * ( 1.0 - ( ztmelts - rtt )   &
379               / ( t_bo_b(ji) - rtt ) )           &
380               - rcp * ( ztmelts-rtt ) )
381            ze_newice(ji)     =   MAX( ze_newice(ji) , 0.0 ) +                 &
382               MAX( 0.0 , SIGN( 1.0 , - ze_newice(ji) ) )   & 
383               * rhoic * lfus
384         END DO ! ji
385         !----------------
386         ! Age of new ice
387         !----------------
388         DO ji = 1, nbpac
389            zo_newice(ji)     = 0.0
390         END DO ! ji
391
392         !--------------------------
393         ! Open water energy budget
394         !--------------------------
395         DO ji = 1, nbpac
396            zqbgow(ji)        = qldif_1d(ji) - qcmif_1d(ji) !<0
397         END DO ! ji
398
399         !-------------------
400         ! Volume of new ice
401         !-------------------
402         DO ji = 1, nbpac
403            zv_newice(ji)     = - zqbgow(ji) / ze_newice(ji)
404
405            ! A fraction zfrazb of frazil ice is accreted at the ice bottom
406            zfrazb        = ( TANH ( Cfrazb * ( zvrel_ac(ji) - vfrazb ) )     & 
407               + 1.0 ) / 2.0 * maxfrazb
408            zdh_frazb(ji) = zfrazb*zv_newice(ji)
409            zv_newice(ji) = ( 1.0 - zfrazb ) * zv_newice(ji)
410         END DO
411
412         !---------------------------------
413         ! Salt flux due to new ice growth
414         !---------------------------------
415         IF ( ( num_sal .EQ. 4 ) ) THEN
416            DO ji = 1, nbpac
417               zji            = MOD( npac(ji) - 1, jpi ) + 1
418               zjj            = ( npac(ji) - 1 ) / jpi + 1
419               fseqv_1d(ji)   = fseqv_1d(ji) +                                     &
420                  ( sss_m(zji,zjj) - bulk_sal      ) * rhoic *       &
421                  zv_newice(ji) / rdt_ice
422            END DO
423         ELSE
424            DO ji = 1, nbpac
425               zji            = MOD( npac(ji) - 1, jpi ) + 1
426               zjj            = ( npac(ji) - 1 ) / jpi + 1
427               fseqv_1d(ji)   = fseqv_1d(ji) +                                     &
428                  ( sss_m(zji,zjj) - zs_newice(ji) ) * rhoic *       &
429                  zv_newice(ji) / rdt_ice
430            END DO ! ji
431         ENDIF
432
433         !------------------------------------
434         ! Diags for energy conservation test
435         !------------------------------------
436         DO ji = 1, nbpac
437            ! Volume
438            zji                  = MOD( npac(ji) - 1, jpi ) + 1
439            zjj                  = ( npac(ji) - 1 ) / jpi + 1
440            vt_i_init(zji,zjj)   = vt_i_init(zji,zjj) + zv_newice(ji)
441            ! Energy
442            zde                  = ze_newice(ji) / unit_fac
443            zde                  = zde * area(zji,zjj) * zv_newice(ji)
444            et_i_init(zji,zjj)   = et_i_init(zji,zjj) + zde
445         END DO
446
447         ! keep new ice volume in memory
448         CALL tab_1d_2d( nbpac, v_newice , npac(1:nbpac), zv_newice(1:nbpac) , &
449            jpi, jpj )
450
451         !-----------------
452         ! Area of new ice
453         !-----------------
454         DO ji = 1, nbpac
455            za_newice(ji)     = zv_newice(ji) / zh_newice(ji)
456            ! diagnostic
457            zji                  = MOD( npac(ji) - 1, jpi ) + 1
458            zjj                  = ( npac(ji) - 1 ) / jpi + 1
459            diag_lat_gr(zji,zjj) = zv_newice(ji) / rdt_ice
460         END DO !ji
461
462         !------------------------------------------------------------------------------!
463         ! 6) Redistribute new ice area and volume into ice categories                  !
464         !------------------------------------------------------------------------------!
465
466         !-----------------------------------------
467         ! Keep old ice areas and volume in memory
468         !-----------------------------------------
469         zv_old(:,:) = zv_i_ac(:,:) 
470         za_old(:,:) = za_i_ac(:,:)
471
472         !-------------------------------------------
473         ! Compute excessive new ice area and volume
474         !-------------------------------------------
475         ! If lateral ice growth gives an ice concentration gt 1, then
476         ! we keep the excessive volume in memory and attribute it later
477         ! to bottom accretion
478         DO ji = 1, nbpac
479            ! vectorize
480            IF ( za_newice(ji) .GT. ( 1.0 - zat_i_ac(ji) ) ) THEN
481               zda_res(ji)    = za_newice(ji) - (1.0 - zat_i_ac(ji) )
482               zdv_res(ji)    = zda_res(ji) * zh_newice(ji) 
483               za_newice(ji)  = za_newice(ji) - zda_res(ji)
484               zv_newice(ji)  = zv_newice(ji) - zdv_res(ji)
485            ELSE
486               zda_res(ji) = 0.0
487               zdv_res(ji) = 0.0
488            ENDIF
489         END DO ! ji
490
491         !------------------------------------------------
492         ! Laterally redistribute new ice volume and area
493         !------------------------------------------------
494         zat_i_ac(:) = 0._wp
495         DO jl = 1, jpl
496            DO ji = 1, nbpac
497               IF(  hi_max   (jl-1)  <  zh_newice(ji)   .AND.   &
498                  & zh_newice(ji)    <= hi_max   (jl)         ) THEN
499                  za_i_ac (ji,jl) = za_i_ac (ji,jl) + za_newice(ji)
500                  zv_i_ac (ji,jl) = zv_i_ac (ji,jl) + zv_newice(ji)
501                  zat_i_ac(ji)    = zat_i_ac(ji)    + za_i_ac  (ji,jl)
502                  zcatac  (ji)    = jl
503               ENDIF
504            END DO ! ji
505         END DO ! jl
506
507         !----------------------------------
508         ! Heat content - lateral accretion
509         !----------------------------------
510         DO ji = 1, nbpac
511            jl = zcatac(ji)                                                           ! categroy in which new ice is put
512            zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , -za_old(ji,jl) ) )             ! zindb=1 if ice =0 otherwise
513            zhice_old(ji,jl) = zv_old(ji,jl) / MAX( za_old(ji,jl) , epsi10 ) * zindb  ! old ice thickness
514            zdhex    (ji) = MAX( 0._wp , zh_newice(ji) - zhice_old(ji,jl) )           ! difference in thickness
515            zswinew  (ji) = MAX( 0._wp , SIGN( 1._wp , - za_old(ji,jl) + epsi11 ) )   ! ice totally new in jl category
516         END DO
517
518         DO jk = 1, nlay_i
519            DO ji = 1, nbpac
520               jl = zcatac(ji)
521               zqold   = ze_i_ac(ji,jk,jl) ! [ J.m-3 ]
522               zalphai = MIN( zhice_old(ji,jl) *   jk       / nlay_i , zh_newice(ji) )   &
523                  &    - MIN( zhice_old(ji,jl) * ( jk - 1 ) / nlay_i , zh_newice(ji) )
524               ze_i_ac(ji,jk,jl) = zswinew(ji) * ze_newice(ji)                                     &
525                  + ( 1.0 - zswinew(ji) ) * ( za_old(ji,jl)  * zqold * zhice_old(ji,jl) / nlay_i   &
526                  + za_newice(ji)  * ze_newice(ji) * zalphai                                       &
527                  + za_newice(ji)  * ze_newice(ji) * zdhex(ji) / nlay_i ) / ( ( zv_i_ac(ji,jl) ) / nlay_i )
528            END DO
529         END DO
530
531         !-----------------------------------------------
532         ! Add excessive volume of new ice at the bottom
533         !-----------------------------------------------
534         ! If the ice concentration exceeds 1, the remaining volume of new ice
535         ! is equally redistributed among all ice categories in which there is
536         ! ice
537
538         ! Fraction of level ice
539         jm = 1
540         zat_i_lev(:) = 0._wp
541
542         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
543            DO ji = 1, nbpac
544               zat_i_lev(ji) = zat_i_lev(ji) + za_i_ac(ji,jl) 
545            END DO
546         END DO
547
548         IF( ln_nicep ) WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl)
549         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
550            DO ji = 1, nbpac
551               zindb = MAX( 0._wp, SIGN( 1._wp , zdv_res(ji) ) )
552               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 )
553            END DO
554         END DO
555         IF( ln_nicep )   WRITE(numout,*) ' zv_i_ac : ', zv_i_ac(jiindx, 1:jpl)
556
557         !---------------------------------
558         ! Heat content - bottom accretion
559         !---------------------------------
560         jm = 1
561         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
562            DO ji = 1, nbpac
563               zindb =  1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl ) ) )       ! zindb=1 if ice =0 otherwise
564               zhice_old(ji,jl) = zv_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb
565               zdhicbot (ji,jl) = zdv_res(ji)    / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb    &
566                  &             +  zindb * zdh_frazb(ji)                               ! frazil ice may coalesce
567               zdummy(ji,jl)    = zv_i_ac(ji,jl)/MAX(za_i_ac(ji,jl),epsi10)*zindb      ! thickness of residual ice
568            END DO
569         END DO
570
571         ! old layers thicknesses and enthalpies
572         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
573            DO jk = 1, nlay_i
574               DO ji = 1, nbpac
575                  zthick0(ji,jk,jl) =  zhice_old(ji,jl) / nlay_i
576                  zqm0   (ji,jk,jl) =  ze_i_ac(ji,jk,jl) * zthick0(ji,jk,jl)
577               END DO
578            END DO
579         END DO
580!!gm ???  why the previous do loop  if ocerwriten by the following one ?
581         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
582            DO ji = 1, nbpac
583               zthick0(ji,nlay_i+1,jl) =  zdhicbot(ji,jl)
584               zqm0   (ji,nlay_i+1,jl) =  ze_newice(ji) * zdhicbot(ji,jl)
585            END DO ! ji
586         END DO ! jl
587
588         ! Redistributing energy on the new grid
589         ze_i_ac(:,:,:) = 0._wp
590         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
591            DO jk = 1, nlay_i
592               DO layer = 1, nlay_i + 1
593                  DO ji = 1, nbpac
594                     zindb =  1._wp -  MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) ) ) 
595                     ! Redistributing energy on the new grid
596                     zweight = MAX (  MIN( zhice_old(ji,jl) * layer , zdummy(ji,jl) * jk )   &
597                        &    - MAX( zhice_old(ji,jl) * ( layer - 1 ) , zdummy(ji,jl) * ( jk - 1 ) ) , 0._wp )   &
598                        &    /( MAX(nlay_i * zthick0(ji,layer,jl),epsi10) ) * zindb
599                     ze_i_ac(ji,jk,jl) =  ze_i_ac(ji,jk,jl) + zweight * zqm0(ji,layer,jl) 
600                  END DO ! ji
601               END DO ! layer
602            END DO ! jk
603         END DO ! jl
604
605         DO jl = ice_cat_bounds(jm,1), ice_cat_bounds(jm,2)
606            DO jk = 1, nlay_i
607               DO ji = 1, nbpac
608                  zindb =  1._wp -  MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) ) ) 
609                  ze_i_ac(ji,jk,jl) = ze_i_ac(ji,jk,jl)   &
610                     &              / MAX( zv_i_ac(ji,jl) , epsi10) * za_i_ac(ji,jl) * nlay_i * zindb
611               END DO
612            END DO
613         END DO
614
615         !------------
616         ! Update age
617         !------------
618         DO jl = 1, jpl
619            DO ji = 1, nbpac
620               zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - za_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes
621               zoa_i_ac(ji,jl)  = za_old(ji,jl) * zoa_i_ac(ji,jl) / MAX( za_i_ac(ji,jl) , epsi10 ) * zindb   
622            END DO
623         END DO   
624
625         !-----------------
626         ! Update salinity
627         !-----------------
628         IF(  num_sal == 2  .OR.  num_sal == 4  ) THEN
629            DO jl = 1, jpl
630               DO ji = 1, nbpac
631                  zindb = 1._wp - MAX( 0._wp , SIGN( 1._wp , - zv_i_ac(ji,jl) ) )  ! 0 if no ice and 1 if yes
632                  zdv   = zv_i_ac(ji,jl) - zv_old(ji,jl)
633                  zsmv_i_ac(ji,jl) = ( zsmv_i_ac(ji,jl) + zdv * zs_newice(ji) ) * zindb
634               END DO
635            END DO   
636         ENDIF
637
638         !------------------------------------------------------------------------------!
639         ! 8) Change 2D vectors to 1D vectors
640         !------------------------------------------------------------------------------!
641         DO jl = 1, jpl
642            CALL tab_1d_2d( nbpac, a_i (:,:,jl), npac(1:nbpac), za_i_ac (1:nbpac,jl), jpi, jpj )
643            CALL tab_1d_2d( nbpac, v_i (:,:,jl), npac(1:nbpac), zv_i_ac (1:nbpac,jl), jpi, jpj )
644            CALL tab_1d_2d( nbpac, oa_i(:,:,jl), npac(1:nbpac), zoa_i_ac(1:nbpac,jl), jpi, jpj )
645            IF (  num_sal == 2  .OR.  num_sal == 4  )   &
646               CALL tab_1d_2d( nbpac, smv_i (:,:,jl), npac(1:nbpac), zsmv_i_ac(1:nbpac,jl) , jpi, jpj )
647            DO jk = 1, nlay_i
648               CALL tab_1d_2d( nbpac, e_i(:,:,jk,jl), npac(1:nbpac), ze_i_ac(1:nbpac,jk,jl), jpi, jpj )
649            END DO
650         END DO
651         CALL tab_1d_2d( nbpac, fseqv , npac(1:nbpac), fseqv_1d  (1:nbpac) , jpi, jpj )
652         !
653      ENDIF ! nbpac > 0
654
655      !------------------------------------------------------------------------------!
656      ! 9) Change units for e_i
657      !------------------------------------------------------------------------------!   
658      DO jl = 1, jpl
659         DO jk = 1, nlay_i          ! heat content in 10^9 Joules
660            e_i(:,:,jk,jl) = e_i(:,:,jk,jl) * area(:,:) * v_i(:,:,jl) / nlay_i  / unit_fac 
661         END DO
662      END DO
663
664      !------------------------------------------------------------------------------|
665      ! 10) Conservation check and changes in each ice category
666      !------------------------------------------------------------------------------|
667      IF( con_i ) THEN
668         CALL lim_column_sum (jpl,   v_i, vt_i_final)
669         fieldid = 'v_i, limthd_lac'
670         CALL lim_cons_check (vt_i_init, vt_i_final, 1.0e-6, fieldid) 
671         !
672         CALL lim_column_sum_energy(jpl, nlay_i, e_i, et_i_final)
673         fieldid = 'e_i, limthd_lac'
674         CALL lim_cons_check (et_i_final, et_i_final, 1.0e-3, fieldid) 
675         !
676         CALL lim_column_sum (jpl,   v_s, vt_s_final)
677         fieldid = 'v_s, limthd_lac'
678         CALL lim_cons_check (vt_s_init, vt_s_final, 1.0e-6, fieldid) 
679         !
680         !     CALL lim_column_sum (jpl,   e_s(:,:,1,:) , et_s_init)
681         !     fieldid = 'e_s, limthd_lac'
682         !     CALL lim_cons_check (et_s_init, et_s_final, 1.0e-3, fieldid)
683         IF( ln_nicep ) THEN
684            WRITE(numout,*) ' vt_i_init : ', vt_i_init(jiindx,jjindx)
685            WRITE(numout,*) ' vt_i_final: ', vt_i_final(jiindx,jjindx)
686            WRITE(numout,*) ' et_i_init : ', et_i_init(jiindx,jjindx)
687            WRITE(numout,*) ' et_i_final: ', et_i_final(jiindx,jjindx)
688         ENDIF
689         !
690      ENDIF
691      !
692      IF( wrk_not_released(1, 1,2,3,4,5,6,7,8,9,10,11,12,13,14) .OR.     &
693          wrk_not_released(2, 1,2,3,4,5,6,7,8)                       )   &
694          CALL ctl_stop( 'lim_thd_lac : failed to release workspace arrays' )
695      !
696   END SUBROUTINE lim_thd_lac
697
698#else
699   !!----------------------------------------------------------------------
700   !!   Default option                               NO  LIM3 sea-ice model
701   !!----------------------------------------------------------------------
702CONTAINS
703   SUBROUTINE lim_thd_lac           ! Empty routine
704   END SUBROUTINE lim_thd_lac
705#endif
706
707   !!======================================================================
708END MODULE limthd_lac
Note: See TracBrowser for help on using the repository browser.