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.

icethd.F90 in NEMO/branches/2020/dev_r13898_Tiling_Cleanup_MPI3/src/ICE – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r13898_Tiling_Cleanup_MPI3/src/ICE/icethd.F90 @ 14345

Last change on this file since 14345 was 13906, checked in by mocavero, 4 years ago
Merge with dev_r13296_HPC-07_mocavero_mpi3
Property svn:keywords set to `Id`
File size: 35.4 KB

Line
1	MODULE icethd
2	!!======================================================================
3	!! * MODULE icethd *
4	!! sea-ice : master routine for thermodynamics
5	!!======================================================================
6	!! History : 1.0 ! 2000-01 (M.A. Morales Maqueda, H. Goosse, T. Fichefet) original code 1D
7	!! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube]
8	!!----------------------------------------------------------------------
9	#if defined key_si3
10	!!----------------------------------------------------------------------
11	!! 'key_si3' SI3 sea-ice model
12	!!----------------------------------------------------------------------
13	!! ice_thd : thermodynamics of sea ice
14	!! ice_thd_init : initialisation of sea-ice thermodynamics
15	!!----------------------------------------------------------------------
16	USE phycst ! physical constants
17	USE dom_oce ! ocean space and time domain variables
18	USE ice ! sea-ice: variables
19	!!gm list trop longue ==>>> why not passage en argument d'appel ?
20	USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, sprecip, ln_cpl
21	USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, &
22	& qml_ice, qcn_ice, qtr_ice_top
23	USE ice1D ! sea-ice: thermodynamics variables
24	USE icethd_zdf ! sea-ice: vertical heat diffusion
25	USE icethd_dh ! sea-ice: ice-snow growth and melt
26	USE icethd_da ! sea-ice: lateral melting
27	USE icethd_sal ! sea-ice: salinity
28	USE icethd_ent ! sea-ice: enthalpy redistribution
29	USE icethd_do ! sea-ice: growth in open water
30	USE icethd_pnd ! sea-ice: melt ponds
31	USE iceitd ! sea-ice: remapping thickness distribution
32	USE icecor ! sea-ice: corrections
33	USE icetab ! sea-ice: 1D <==> 2D transformation
34	USE icevar ! sea-ice: operations
35	USE icectl ! sea-ice: control print
36	!
37	USE in_out_manager ! I/O manager
38	USE iom ! I/O manager library
39	USE lib_mpp ! MPP library
40	USE lib_fortran ! fortran utilities (glob_sum + no signed zero)
41	USE lbclnk ! lateral boundary conditions (or mpp links)
42	USE timing ! Timing
43
44	IMPLICIT NONE
45	PRIVATE
46
47	PUBLIC ice_thd ! called by limstp module
48	PUBLIC ice_thd_init ! called by ice_init
49
50	!! namelist (namthd)
51	LOGICAL :: ln_icedH ! activate ice thickness change from growing/melting (T) or not (F)
52	LOGICAL :: ln_icedA ! activate lateral melting param. (T) or not (F)
53	LOGICAL :: ln_icedO ! activate ice growth in open-water (T) or not (F)
54	LOGICAL :: ln_icedS ! activate gravity drainage and flushing (T) or not (F)
55	LOGICAL :: ln_leadhfx ! heat in the leads is used to melt sea-ice before warming the ocean
56
57	!! for convergence tests
58	REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztice_cvgerr, ztice_cvgstp
59
60	!! * Substitutions
61	# include "do_loop_substitute.h90"
62	!!----------------------------------------------------------------------
63	!! NEMO/ICE 4.0 , NEMO Consortium (2018)
64	!! $Id$
65	!! Software governed by the CeCILL license (see ./LICENSE)
66	!!----------------------------------------------------------------------
67	CONTAINS
68
69	SUBROUTINE ice_thd( kt )
70	!!-------------------------------------------------------------------
71	!! * ROUTINE ice_thd *
72	!!
73	!! ** Purpose : This routine manages ice thermodynamics
74	!!
75	!! ** Action : - computation of oceanic sensible heat flux at the ice base
76	!! energy budget in the leads
77	!! net fluxes on top of ice and of ocean
78	!! - selection of grid cells with ice
79	!! - call ice_thd_zdf for vertical heat diffusion
80	!! - call ice_thd_dh for vertical ice growth and melt
81	!! - call ice_thd_pnd for melt ponds
82	!! - call ice_thd_ent for enthalpy remapping
83	!! - call ice_thd_sal for ice desalination
84	!! - call ice_thd_temp to retrieve temperature from ice enthalpy
85	!! - call ice_thd_mono for extra lateral ice melt if active virtual thickness distribution
86	!! - call ice_thd_da for lateral ice melt
87	!! - back to the geographic grid
88	!! - call ice_thd_rem for remapping thickness distribution
89	!! - call ice_thd_do for ice growth in leads
90	!!-------------------------------------------------------------------
91	INTEGER, INTENT(in) :: kt ! number of iteration
92	!
93	INTEGER :: ji, jj, jk, jl ! dummy loop indices
94	REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg, zqfr_pos
95	REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04)
96	REAL(wp), PARAMETER :: zch = 0.0057_wp ! heat transfer coefficient
97	REAL(wp), DIMENSION(jpi,jpj) :: zu_io, zv_io, zfric, zvel ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)
98	!
99	!!-------------------------------------------------------------------
100	! controls
101	IF( ln_timing ) CALL timing_start('icethd') ! timing
102	IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
103	IF( ln_icediachk ) CALL ice_cons2D (0, 'icethd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft) ! conservation
104
105	IF( kt == nit000 .AND. lwp ) THEN
106	WRITE(numout,*)
107	WRITE(numout,*) 'ice_thd: sea-ice thermodynamics'
108	WRITE(numout,*) '~~~~~~~'
109	ENDIF
110
111	! convergence tests
112	IF( ln_zdf_chkcvg ) THEN
113	ALLOCATE( ztice_cvgerr(jpi,jpj,jpl) , ztice_cvgstp(jpi,jpj,jpl) )
114	ztice_cvgerr = 0._wp ; ztice_cvgstp = 0._wp
115	ENDIF
116
117	!---------------------------------------------!
118	! computation of friction velocity at T points
119	!---------------------------------------------!
120	IF( ln_icedyn ) THEN
121	zu_io(:,:) = u_ice(:,:) - ssu_m(:,:)
122	zv_io(:,:) = v_ice(:,:) - ssv_m(:,:)
123	DO_2D( 0, 0, 0, 0 )
124	zfric(ji,jj) = rn_cio * ( 0.5_wp * &
125	& ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) &
126	& + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1)
127	zvel(ji,jj) = 0.5_wp * SQRT( ( u_ice(ji-1,jj) + u_ice(ji,jj) ) * ( u_ice(ji-1,jj) + u_ice(ji,jj) ) + &
128	& ( v_ice(ji,jj-1) + v_ice(ji,jj) ) * ( v_ice(ji,jj-1) + v_ice(ji,jj) ) )
129	END_2D
130	ELSE ! if no ice dynamics => transmit directly the atmospheric stress to the ocean
131	DO_2D( 0, 0, 0, 0 )
132	zfric(ji,jj) = r1_rho0 * SQRT( 0.5_wp * &
133	& ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) &
134	& + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1)
135	zvel(ji,jj) = 0._wp
136	END_2D
137	ENDIF
138	#if defined key_mpi3
139	CALL lbc_lnk_nc_multi( 'icethd', zfric, 'T', 1.0_wp, zvel, 'T', 1.0_wp )
140	#else
141	CALL lbc_lnk_multi( 'icethd', zfric, 'T', 1.0_wp, zvel, 'T', 1.0_wp )
142	#endif
143	!
144	!--------------------------------------------------------------------!
145	! Partial computation of forcing for the thermodynamic sea ice model
146	!--------------------------------------------------------------------!
147	DO_2D( 1, 1, 1, 1 )
148	rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice
149	!
150	! --- Energy received in the lead from atm-oce exchanges, zqld is defined everywhere (J.m-2) --- !
151	zqld = tmask(ji,jj,1) * rDt_ice * &
152	& ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + &
153	& ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) )
154
155	! --- Energy needed to bring ocean surface layer until its freezing, zqfr is defined everywhere (J.m-2) --- !
156	! (mostly<0 but >0 if supercooling)
157	zqfr = rho0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ) * tmask(ji,jj,1) ! both < 0 (t_bo < sst) and > 0 (t_bo > sst)
158	zqfr_neg = MIN( zqfr , 0._wp ) ! only < 0
159	zqfr_pos = MAX( zqfr , 0._wp ) ! only > 0
160
161	! --- Sensible ocean-to-ice heat flux (W/m2) --- !
162	! (mostly>0 but <0 if supercooling)
163	zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin )
164	qsb_ice_bot(ji,jj) = rswitch * rho0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) )
165
166	! upper bound for qsb_ice_bot: the heat retrieved from the ocean must be smaller than the heat necessary to reach
167	! the freezing point, so that we do not have SST < T_freeze
168	! This implies: qsb_ice_bot(ji,jj) * at_i(ji,jj) * rtdice <= - zqfr_neg
169	! The following formulation is ok for both normal conditions and supercooling
170	qsb_ice_bot(ji,jj) = rswitch * MIN( qsb_ice_bot(ji,jj), - zqfr_neg * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) )
171
172	! --- Energy Budget of the leads (qlead, J.m-2) --- !
173	! qlead is the energy received from the atm. in the leads.
174	! If warming (zqld >= 0), then the energy in the leads is used to melt ice (bottom melting) => fhld (W/m2)
175	! If cooling (zqld < 0), then the energy in the leads is used to grow ice in open water => qlead (J.m-2)
176	IF( zqld >= 0._wp .AND. at_i(ji,jj) > 0._wp ) THEN
177	! upper bound for fhld: fhld should be equal to zqld
178	! but we have to make sure that this heat will not make the sst drop below the freezing point
179	! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr_pos
180	! The following formulation is ok for both normal conditions and supercooling
181	fhld (ji,jj) = rswitch * MAX( 0._wp, ( zqld - zqfr_pos ) * r1_Dt_ice / MAX( at_i(ji,jj), epsi10 ) & ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90
182	& - qsb_ice_bot(ji,jj) )
183	qlead(ji,jj) = 0._wp
184	ELSE
185	fhld (ji,jj) = 0._wp
186	! upper bound for qlead: qlead should be equal to zqld
187	! but before using this heat for ice formation, we suppose that the ocean cools down till the freezing point.
188	! The energy for this cooling down is zqfr. Also some heat will be removed from the ocean from turbulent fluxes (qsb)
189	! and freezing point is reached if zqfr = zqld - qsb*a/dt
190	! so the max heat that can be pulled out of the ocean is zqld - qsb - zqfr
191	! The following formulation is ok for both normal conditions and supercooling
192	qlead(ji,jj) = MIN( 0._wp , zqld - ( qsb_ice_bot(ji,jj) * at_i(ji,jj) * rDt_ice ) - zqfr )
193	ENDIF
194	!
195	! If ice is landfast and ice concentration reaches its max
196	! => stop ice formation in open water
197	IF( zvel(ji,jj) <= 5.e-04_wp .AND. at_i(ji,jj) >= rn_amax_2d(ji,jj)-epsi06 ) qlead(ji,jj) = 0._wp
198	!
199	! If the grid cell is almost fully covered by ice (no leads)
200	! => stop ice formation in open water
201	IF( at_i(ji,jj) >= (1._wp - epsi10) ) qlead(ji,jj) = 0._wp
202	!
203	! If ln_leadhfx is false
204	! => do not use energy of the leads to melt sea-ice
205	IF( .NOT.ln_leadhfx ) fhld(ji,jj) = 0._wp
206	!
207	END_2D
208
209	! In case we bypass open-water ice formation
210	IF( .NOT. ln_icedO ) qlead(:,:) = 0._wp
211	! In case we bypass growing/melting from top and bottom
212	IF( .NOT. ln_icedH ) THEN
213	qsb_ice_bot(:,:) = 0._wp
214	fhld (:,:) = 0._wp
215	ENDIF
216
217	!-------------------------------------------------------------------------------------------!
218	! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories
219	!-------------------------------------------------------------------------------------------!
220	DO jl = 1, jpl
221
222	! select ice covered grid points
223	npti = 0 ; nptidx(:) = 0
224	DO_2D( 1, 1, 1, 1 )
225	IF ( a_i(ji,jj,jl) > epsi10 ) THEN
226	npti = npti + 1
227	nptidx(npti) = (jj - 1) * jpi + ji
228	ENDIF
229	END_2D
230
231	IF( npti > 0 ) THEN ! If there is no ice, do nothing.
232	!
233	CALL ice_thd_1d2d( jl, 1 ) ! --- Move to 1D arrays --- !
234	! ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- !
235	!
236	s_i_new (1:npti) = 0._wp ; dh_s_tot(1:npti) = 0._wp ! --- some init --- ! (important to have them here)
237	dh_i_sum (1:npti) = 0._wp ; dh_i_bom(1:npti) = 0._wp ; dh_i_itm (1:npti) = 0._wp
238	dh_i_sub (1:npti) = 0._wp ; dh_i_bog(1:npti) = 0._wp
239	dh_snowice(1:npti) = 0._wp ; dh_s_mlt(1:npti) = 0._wp
240	!
241	CALL ice_thd_zdf ! --- Ice-Snow temperature --- !
242	!
243	IF( ln_icedH ) THEN ! --- Growing/Melting --- !
244	CALL ice_thd_dh ! Ice-Snow thickness
245	CALL ice_thd_pnd ! Melt ponds formation
246	CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping
247	ENDIF
248	CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- !
249	!
250	CALL ice_thd_temp ! --- Temperature update --- !
251	!
252	IF( ln_icedH .AND. ln_virtual_itd ) &
253	& CALL ice_thd_mono ! --- Extra lateral melting if virtual_itd --- !
254	!
255	IF( ln_icedA ) CALL ice_thd_da ! --- Lateral melting --- !
256	!
257	CALL ice_thd_1d2d( jl, 2 ) ! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
258	! ! --- & Move to 2D arrays --- !
259	ENDIF
260	!
261	END DO
262	!
263	IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
264	IF( ln_icediachk ) CALL ice_cons2D (1, 'icethd', diag_v, diag_s, diag_t, diag_fv, diag_fs, diag_ft)
265	!
266	IF( jpl > 1 ) CALL ice_itd_rem( kt ) ! --- Transport ice between thickness categories --- !
267	!
268	IF( ln_icedO ) CALL ice_thd_do ! --- Frazil ice growth in leads --- !
269	!
270	CALL ice_cor( kt , 2 ) ! --- Corrections --- !
271	!
272	oa_i(:,:,:) = oa_i(:,:,:) + a_i(:,:,:) * rdt_ice ! ice natural aging incrementation
273	!
274	! convergence tests
275	IF( ln_zdf_chkcvg ) THEN
276	CALL iom_put( 'tice_cvgerr', ztice_cvgerr ) ; DEALLOCATE( ztice_cvgerr )
277	CALL iom_put( 'tice_cvgstp', ztice_cvgstp ) ; DEALLOCATE( ztice_cvgstp )
278	ENDIF
279	!
280	! controls
281	IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ') ! prints
282	IF( sn_cfctl%l_prtctl ) &
283	& CALL ice_prt3D ('icethd') ! prints
284	IF( ln_timing ) CALL timing_stop('icethd') ! timing
285	!
286	END SUBROUTINE ice_thd
287
288
289	SUBROUTINE ice_thd_temp
290	!!-----------------------------------------------------------------------
291	!! * ROUTINE ice_thd_temp *
292	!!
293	!! ** Purpose : Computes sea ice temperature (Kelvin) from enthalpy
294	!!
295	!! ** Method : Formula (Bitz and Lipscomb, 1999)
296	!!-------------------------------------------------------------------
297	INTEGER :: ji, jk ! dummy loop indices
298	REAL(wp) :: ztmelts, zbbb, zccc ! local scalar
299	!!-------------------------------------------------------------------
300	! Recover ice temperature
301	DO jk = 1, nlay_i
302	DO ji = 1, npti
303	ztmelts = -rTmlt * sz_i_1d(ji,jk)
304	! Conversion q(S,T) -> T (second order equation)
305	zbbb = ( rcp - rcpi ) * ztmelts + e_i_1d(ji,jk) * r1_rhoi - rLfus
306	zccc = SQRT( MAX( zbbb * zbbb - 4._wp * rcpi * rLfus * ztmelts, 0._wp ) )
307	t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_rcpi
308
309	! mask temperature
310	rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) )
311	t_i_1d(ji,jk) = rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rt0
312	END DO
313	END DO
314	!
315	END SUBROUTINE ice_thd_temp
316
317
318	SUBROUTINE ice_thd_mono
319	!!-----------------------------------------------------------------------
320	!! * ROUTINE ice_thd_mono *
321	!!
322	!! ** Purpose : Lateral melting in case virtual_itd
323	!! ( dA = A/2h dh )
324	!!-----------------------------------------------------------------------
325	INTEGER :: ji ! dummy loop indices
326	REAL(wp) :: zhi_bef ! ice thickness before thermo
327	REAL(wp) :: zdh_mel, zda_mel ! net melting
328	REAL(wp) :: zvi, zvs ! ice/snow volumes
329	!!-----------------------------------------------------------------------
330	!
331	DO ji = 1, npti
332	zdh_mel = MIN( 0._wp, dh_i_itm(ji) + dh_i_sum(ji) + dh_i_bom(ji) + dh_snowice(ji) + dh_i_sub(ji) )
333	IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN
334	zvi = a_i_1d(ji) * h_i_1d(ji)
335	zvs = a_i_1d(ji) * h_s_1d(ji)
336	! lateral melting = concentration change
337	zhi_bef = h_i_1d(ji) - zdh_mel
338	rswitch = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) )
339	zda_mel = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) )
340	a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel )
341	! adjust thickness
342	h_i_1d(ji) = zvi / a_i_1d(ji)
343	h_s_1d(ji) = zvs / a_i_1d(ji)
344	! retrieve total concentration
345	at_i_1d(ji) = a_i_1d(ji)
346	END IF
347	END DO
348	!
349	END SUBROUTINE ice_thd_mono
350
351
352	SUBROUTINE ice_thd_1d2d( kl, kn )
353	!!-----------------------------------------------------------------------
354	!! * ROUTINE ice_thd_1d2d *
355	!!
356	!! ** Purpose : move arrays from 1d to 2d and the reverse
357	!!-----------------------------------------------------------------------
358	INTEGER, INTENT(in) :: kl ! index of the ice category
359	INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D
360	!
361	INTEGER :: jk ! dummy loop indices
362	!!-----------------------------------------------------------------------
363	!
364	SELECT CASE( kn )
365	! !---------------------!
366	CASE( 1 ) !== from 2D to 1D ==!
367	! !---------------------!
368	CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i )
369	CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl) )
370	CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl) )
371	CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl) )
372	CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl) )
373	CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl) )
374	DO jk = 1, nlay_s
375	CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl) )
376	CALL tab_2d_1d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl) )
377	END DO
378	DO jk = 1, nlay_i
379	CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl) )
380	CALL tab_2d_1d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl) )
381	CALL tab_2d_1d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) )
382	END DO
383	CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
384	CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
385	CALL tab_2d_1d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )
386	!
387	CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d (1:npti), qprec_ice )
388	CALL tab_2d_1d( npti, nptidx(1:npti), qsr_ice_1d (1:npti), qsr_ice (:,:,kl) )
389	CALL tab_2d_1d( npti, nptidx(1:npti), qns_ice_1d (1:npti), qns_ice (:,:,kl) )
390	CALL tab_2d_1d( npti, nptidx(1:npti), evap_ice_1d (1:npti), evap_ice(:,:,kl) )
391	CALL tab_2d_1d( npti, nptidx(1:npti), dqns_ice_1d (1:npti), dqns_ice(:,:,kl) )
392	CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d (1:npti), t_bo )
393	CALL tab_2d_1d( npti, nptidx(1:npti), sprecip_1d (1:npti), sprecip )
394	CALL tab_2d_1d( npti, nptidx(1:npti), qsb_ice_bot_1d(1:npti), qsb_ice_bot )
395	CALL tab_2d_1d( npti, nptidx(1:npti), fhld_1d (1:npti), fhld )
396
397	CALL tab_2d_1d( npti, nptidx(1:npti), qml_ice_1d (1:npti), qml_ice (:,:,kl) )
398	CALL tab_2d_1d( npti, nptidx(1:npti), qcn_ice_1d (1:npti), qcn_ice (:,:,kl) )
399	CALL tab_2d_1d( npti, nptidx(1:npti), qtr_ice_top_1d(1:npti), qtr_ice_top(:,:,kl) )
400	!
401	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
402	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum )
403	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sub_1d (1:npti), wfx_sub )
404	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub )
405	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub )
406	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub )
407	!
408	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog )
409	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom )
410	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum )
411	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni )
412	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res )
413	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr )
414	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam )
415	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )
416	!
417	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog )
418	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom )
419	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum )
420	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni )
421	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri )
422	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res )
423	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub )
424	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam )
425	!
426	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd )
427	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr )
428	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum )
429	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom )
430	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog )
431	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif )
432	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw )
433	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw )
434	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub )
435	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
436	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
437	!
438	! ocean surface fields
439	CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m )
440	CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m )
441	CALL tab_2d_1d( npti, nptidx(1:npti), frq_m_1d(1:npti), frq_m )
442	!
443	! to update ice age
444	CALL tab_2d_1d( npti, nptidx(1:npti), o_i_1d (1:npti), o_i (:,:,kl) )
445	CALL tab_2d_1d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) )
446	!
447	! --- Change units of e_i, e_s from J/m2 to J/m3 --- !
448	DO jk = 1, nlay_i
449	WHERE( h_i_1d(1:npti)>0._wp ) e_i_1d(1:npti,jk) = e_i_1d(1:npti,jk) / (h_i_1d(1:npti) * a_i_1d(1:npti)) * nlay_i
450	END DO
451	DO jk = 1, nlay_s
452	WHERE( h_s_1d(1:npti)>0._wp ) e_s_1d(1:npti,jk) = e_s_1d(1:npti,jk) / (h_s_1d(1:npti) * a_i_1d(1:npti)) * nlay_s
453	END DO
454	!
455	! !---------------------!
456	CASE( 2 ) !== from 1D to 2D ==!
457	! !---------------------!
458	! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
459	DO jk = 1, nlay_i
460	e_i_1d(1:npti,jk) = e_i_1d(1:npti,jk) * h_i_1d(1:npti) * a_i_1d(1:npti) * r1_nlay_i
461	END DO
462	DO jk = 1, nlay_s
463	e_s_1d(1:npti,jk) = e_s_1d(1:npti,jk) * h_s_1d(1:npti) * a_i_1d(1:npti) * r1_nlay_s
464	END DO
465	!
466	! Change thickness to volume (replaces routine ice_var_eqv2glo)
467	v_i_1d (1:npti) = h_i_1d (1:npti) * a_i_1d (1:npti)
468	v_s_1d (1:npti) = h_s_1d (1:npti) * a_i_1d (1:npti)
469	sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti)
470	v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti)
471	v_il_1d(1:npti) = h_il_1d(1:npti) * a_ip_1d(1:npti)
472	oa_i_1d(1:npti) = o_i_1d (1:npti) * a_i_1d (1:npti)
473
474	CALL tab_1d_2d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i )
475	CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl) )
476	CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl) )
477	CALL tab_1d_2d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl) )
478	CALL tab_1d_2d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl) )
479	CALL tab_1d_2d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl) )
480	DO jk = 1, nlay_s
481	CALL tab_1d_2d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl) )
482	CALL tab_1d_2d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl) )
483	END DO
484	DO jk = 1, nlay_i
485	CALL tab_1d_2d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl) )
486	CALL tab_1d_2d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl) )
487	CALL tab_1d_2d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) )
488	END DO
489	CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
490	CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
491	CALL tab_1d_2d( npti, nptidx(1:npti), h_il_1d (1:npti), h_il (:,:,kl) )
492	!
493	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
494	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum )
495	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sub_1d (1:npti), wfx_sub )
496	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub )
497	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub )
498	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub )
499	!
500	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog )
501	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom )
502	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum )
503	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni )
504	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res )
505	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr )
506	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam )
507	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )
508	!
509	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog )
510	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom )
511	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum )
512	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni )
513	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri )
514	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res )
515	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub )
516	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam )
517	!
518	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd )
519	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr )
520	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum )
521	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom )
522	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog )
523	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif )
524	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw )
525	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw )
526	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub )
527	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
528	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
529	!
530	CALL tab_1d_2d( npti, nptidx(1:npti), qns_ice_1d (1:npti), qns_ice (:,:,kl) )
531	CALL tab_1d_2d( npti, nptidx(1:npti), qtr_ice_bot_1d(1:npti), qtr_ice_bot(:,:,kl) )
532	! effective conductivity and 1st layer temperature (ln_cndflx=T)
533	CALL tab_1d_2d( npti, nptidx(1:npti), cnd_ice_1d(1:npti), cnd_ice(:,:,kl) )
534	CALL tab_1d_2d( npti, nptidx(1:npti), t1_ice_1d (1:npti), t1_ice (:,:,kl) )
535	! SIMIP diagnostics
536	CALL tab_1d_2d( npti, nptidx(1:npti), t_si_1d (1:npti), t_si (:,:,kl) )
537	CALL tab_1d_2d( npti, nptidx(1:npti), qcn_ice_bot_1d(1:npti), qcn_ice_bot(:,:,kl) )
538	CALL tab_1d_2d( npti, nptidx(1:npti), qcn_ice_top_1d(1:npti), qcn_ice_top(:,:,kl) )
539	! extensive variables
540	CALL tab_1d_2d( npti, nptidx(1:npti), v_i_1d (1:npti), v_i (:,:,kl) )
541	CALL tab_1d_2d( npti, nptidx(1:npti), v_s_1d (1:npti), v_s (:,:,kl) )
542	CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) )
543	CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) )
544	CALL tab_1d_2d( npti, nptidx(1:npti), v_il_1d(1:npti), v_il(:,:,kl) )
545	CALL tab_1d_2d( npti, nptidx(1:npti), oa_i_1d(1:npti), oa_i(:,:,kl) )
546	! check convergence of heat diffusion scheme
547	IF( ln_zdf_chkcvg ) THEN
548	CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgerr_1d(1:npti), ztice_cvgerr(:,:,kl) )
549	CALL tab_1d_2d( npti, nptidx(1:npti), tice_cvgstp_1d(1:npti), ztice_cvgstp(:,:,kl) )
550	ENDIF
551	!
552	END SELECT
553	!
554	END SUBROUTINE ice_thd_1d2d
555
556
557	SUBROUTINE ice_thd_init
558	!!-------------------------------------------------------------------
559	!! * ROUTINE ice_thd_init *
560	!!
561	!! ** Purpose : Physical constants and parameters associated with
562	!! ice thermodynamics
563	!!
564	!! ** Method : Read the namthd namelist and check the parameters
565	!! called at the first timestep (nit000)
566	!!
567	!! ** input : Namelist namthd
568	!!-------------------------------------------------------------------
569	INTEGER :: ios ! Local integer output status for namelist read
570	!!
571	NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS, ln_leadhfx
572	!!-------------------------------------------------------------------
573	!
574	READ ( numnam_ice_ref, namthd, IOSTAT = ios, ERR = 901)
575	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd in reference namelist' )
576	READ ( numnam_ice_cfg, namthd, IOSTAT = ios, ERR = 902 )
577	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd in configuration namelist' )
578	IF(lwm) WRITE( numoni, namthd )
579	!
580	IF(lwp) THEN ! control print
581	WRITE(numout,*)
582	WRITE(numout,*) 'ice_thd_init: Ice Thermodynamics'
583	WRITE(numout,*) '~~~~~~~~~~~~'
584	WRITE(numout,*) ' Namelist namthd:'
585	WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH
586	WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA
587	WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO
588	WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS
589	WRITE(numout,*) ' heat in the leads is used to melt sea-ice before warming the ocean ln_leadhfx = ', ln_leadhfx
590	ENDIF
591	!
592	CALL ice_thd_zdf_init ! set ice heat diffusion parameters
593	IF( ln_icedA ) CALL ice_thd_da_init ! set ice lateral melting parameters
594	IF( ln_icedO ) CALL ice_thd_do_init ! set ice growth in open water parameters
595	CALL ice_thd_sal_init ! set ice salinity parameters
596	CALL ice_thd_pnd_init ! set melt ponds parameters
597	!
598	END SUBROUTINE ice_thd_init
599
600	#else
601	!!----------------------------------------------------------------------
602	!! Default option Dummy module NO SI3 sea-ice model
603	!!----------------------------------------------------------------------
604	#endif
605
606	!!======================================================================
607	END MODULE icethd

Note: See TracBrowser for help on using the repository browser.

Download in other formats: