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/trunk/src/ICE – NEMO

Context Navigation

source: NEMO/trunk/src/ICE/icethd.F90 @ 9653

Last change on this file since 9653 was 9604, checked in by clem, 6 years ago
change history of the ice routines
File size: 34.6 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) LIM-1
7	!! 2.0 ! 2002-07 (C. Ethe, G. Madec) LIM-2
8	!! 3.0 ! 2005-11 (M. Vancoppenolle) LIM-3
9	!! 4.0 ! 2018 (many people) SI3 [aka Sea Ice cube]
10	!!----------------------------------------------------------------------
11	#if defined key_si3
12	!!----------------------------------------------------------------------
13	!! 'key_si3' SI3 sea-ice model
14	!!----------------------------------------------------------------------
15	!! ice_thd : thermodynamics of sea ice
16	!! ice_thd_init : initialisation of sea-ice thermodynamics
17	!!----------------------------------------------------------------------
18	USE phycst ! physical constants
19	USE dom_oce ! ocean space and time domain variables
20	USE ice ! sea-ice: variables
21	!!gm list trop longue ==>>> why not passage en argument d'appel ?
22	USE sbc_oce , ONLY : sss_m, sst_m, e3t_m, utau, vtau, ssu_m, ssv_m, frq_m, qns_tot, qsr_tot, sprecip, ln_cpl
23	USE sbc_ice , ONLY : qsr_oce, qns_oce, qemp_oce, qsr_ice, qns_ice, dqns_ice, evap_ice, qprec_ice, qevap_ice, &
24	& qml_ice, qcn_ice, qsr_ice_tr
25	USE ice1D ! sea-ice: thermodynamics variables
26	USE icethd_zdf ! sea-ice: vertical heat diffusion
27	USE icethd_dh ! sea-ice: ice-snow growth and melt
28	USE icethd_da ! sea-ice: lateral melting
29	USE icethd_sal ! sea-ice: salinity
30	USE icethd_ent ! sea-ice: enthalpy redistribution
31	USE icethd_do ! sea-ice: growth in open water
32	USE icethd_pnd ! sea-ice: melt ponds
33	USE iceitd ! sea-ice: remapping thickness distribution
34	USE icetab ! sea-ice: 1D <==> 2D transformation
35	USE icevar ! sea-ice: operations
36	USE icectl ! sea-ice: control print
37	!
38	USE in_out_manager ! I/O manager
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
56	!! * Substitutions
57	# include "vectopt_loop_substitute.h90"
58	!!----------------------------------------------------------------------
59	!! NEMO/ICE 4.0 , NEMO Consortium (2018)
60	!! $Id: icethd.F90 8420 2017-08-08 12:18:46Z clem $
61	!! Software governed by the CeCILL licence (./LICENSE)
62	!!----------------------------------------------------------------------
63	CONTAINS
64
65	SUBROUTINE ice_thd( kt )
66	!!-------------------------------------------------------------------
67	!! * ROUTINE ice_thd *
68	!!
69	!! ** Purpose : This routine manages ice thermodynamics
70	!!
71	!! ** Action : - computation of oceanic sensible heat flux at the ice base
72	!! energy budget in the leads
73	!! net fluxes on top of ice and of ocean
74	!! - selection of grid cells with ice
75	!! - call ice_thd_zdf for vertical heat diffusion
76	!! - call ice_thd_dh for vertical ice growth and melt
77	!! - call ice_thd_pnd for melt ponds
78	!! - call ice_thd_ent for enthalpy remapping
79	!! - call ice_thd_sal for ice desalination
80	!! - call ice_thd_temp to retrieve temperature from ice enthalpy
81	!! - call ice_thd_lam for extra lateral ice melt if active virtual thickness distribution
82	!! - call ice_thd_da for lateral ice melt
83	!! - back to the geographic grid
84	!! - call ice_thd_rem for remapping thickness distribution
85	!! - call ice_thd_do for ice growth in leads
86	!!-------------------------------------------------------------------
87	INTEGER, INTENT(in) :: kt ! number of iteration
88	!
89	INTEGER :: ji, jj, jk, jl ! dummy loop indices
90	REAL(wp) :: zfric_u, zqld, zqfr, zqfr_neg
91	REAL(wp), PARAMETER :: zfric_umin = 0._wp ! lower bound for the friction velocity (cice value=5.e-04)
92	REAL(wp), PARAMETER :: zch = 0.0057_wp ! heat transfer coefficient
93	REAL(wp), DIMENSION(jpi,jpj) :: zu_io, zv_io, zfric ! ice-ocean velocity (m/s) and frictional velocity (m2/s2)
94	!
95	!!-------------------------------------------------------------------
96	! controls
97	IF( ln_timing ) CALL timing_start('icethd') ! timing
98	IF( ln_icediachk ) CALL ice_cons_hsm(0, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft) ! conservation
99
100	IF( kt == nit000 .AND. lwp ) THEN
101	WRITE(numout,*)
102	WRITE(numout,*) 'ice_thd: sea-ice thermodynamics'
103	WRITE(numout,*) '~~~~~~~'
104	ENDIF
105
106	CALL ice_var_glo2eqv
107
108	!---------------------------------------------!
109	! computation of friction velocity at T points
110	!---------------------------------------------!
111	IF( ln_icedyn ) THEN
112	zu_io(:,:) = u_ice(:,:) - ssu_m(:,:)
113	zv_io(:,:) = v_ice(:,:) - ssv_m(:,:)
114	DO jj = 2, jpjm1
115	DO ji = fs_2, fs_jpim1
116	zfric(ji,jj) = rn_cio * ( 0.5_wp * &
117	& ( zu_io(ji,jj) * zu_io(ji,jj) + zu_io(ji-1,jj) * zu_io(ji-1,jj) &
118	& + zv_io(ji,jj) * zv_io(ji,jj) + zv_io(ji,jj-1) * zv_io(ji,jj-1) ) ) * tmask(ji,jj,1)
119	END DO
120	END DO
121	ELSE ! if no ice dynamics => transmit directly the atmospheric stress to the ocean
122	DO jj = 2, jpjm1
123	DO ji = fs_2, fs_jpim1
124	zfric(ji,jj) = r1_rau0 * SQRT( 0.5_wp * &
125	& ( utau(ji,jj) * utau(ji,jj) + utau(ji-1,jj) * utau(ji-1,jj) &
126	& + vtau(ji,jj) * vtau(ji,jj) + vtau(ji,jj-1) * vtau(ji,jj-1) ) ) * tmask(ji,jj,1)
127	END DO
128	END DO
129	ENDIF
130	CALL lbc_lnk( zfric, 'T', 1. )
131	!
132	ftr_ice(:,:,:) = 0._wp ! initialization (part of solar radiation transmitted through the ice)
133
134	!--------------------------------------------------------------------!
135	! Partial computation of forcing for the thermodynamic sea ice model
136	!--------------------------------------------------------------------!
137	DO jj = 1, jpj
138	DO ji = 1, jpi
139	rswitch = tmask(ji,jj,1) * MAX( 0._wp , SIGN( 1._wp , at_i(ji,jj) - epsi10 ) ) ! 0 if no ice
140	!
141	! ! solar irradiance transmission at the mixed layer bottom and used in the lead heat budget
142	! ! practically no "direct lateral ablation"
143	!
144	! ! net downward heat flux from the ice to the ocean, expressed as a function of ocean
145	! ! temperature and turbulent mixing (McPhee, 1992)
146	!
147	! --- Energy received in the lead, zqld is defined everywhere (J.m-2) --- !
148	zqld = tmask(ji,jj,1) * rdt_ice * &
149	& ( ( 1._wp - at_i_b(ji,jj) ) * qsr_oce(ji,jj) * frq_m(ji,jj) + &
150	& ( 1._wp - at_i_b(ji,jj) ) * qns_oce(ji,jj) + qemp_oce(ji,jj) )
151
152	! --- Energy needed to bring ocean surface layer until its freezing (<0, J.m-2) --- !
153	! includes supercooling potential energy (>0) or "above-freezing" energy (<0)
154	zqfr = tmask(ji,jj,1) * rau0 * rcp * e3t_m(ji,jj) * ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) )
155
156	! --- Above-freezing sensible heat content (J/m2 grid)
157	zqfr_neg = tmask(ji,jj,1) * rau0 * rcp * e3t_m(ji,jj) * MIN( ( t_bo(ji,jj) - ( sst_m(ji,jj) + rt0 ) ), 0._wp )
158
159	! --- Sensible ocean-to-ice heat flux (W/m2)
160	zfric_u = MAX( SQRT( zfric(ji,jj) ), zfric_umin )
161	fhtur(ji,jj) = rswitch * rau0 * rcp * zch * zfric_u * ( ( sst_m(ji,jj) + rt0 ) - t_bo(ji,jj) ) ! W.m-2
162
163	fhtur(ji,jj) = rswitch * MIN( fhtur(ji,jj), - zqfr_neg * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) )
164	! upper bound for fhtur: the heat retrieved from the ocean must be smaller than the heat necessary to reach
165	! the freezing point, so that we do not have SST < T_freeze
166	! This implies: - ( fhtur(ji,jj) * at_i(ji,jj) * rtdice ) - zqfr >= 0
167
168	!-- Energy Budget of the leads (J.m-2), source of lateral accretion. Must be < 0 to form ice
169	qlead(ji,jj) = MIN( 0._wp , zqld - ( fhtur(ji,jj) * at_i(ji,jj) * rdt_ice ) - zqfr )
170
171	! If there is ice and leads are warming, then transfer energy from the lead budget and use it for bottom melting
172	IF( zqld > 0._wp ) THEN
173	fhld (ji,jj) = rswitch * zqld * r1_rdtice / MAX( at_i(ji,jj), epsi10 ) ! divided by at_i since this is (re)multiplied by a_i in icethd_dh.F90
174	qlead(ji,jj) = 0._wp
175	ELSE
176	fhld (ji,jj) = 0._wp
177	ENDIF
178	!
179	! Net heat flux on top of the ice-ocean [W.m-2]
180	! ---------------------------------------------
181	hfx_in(ji,jj) = qns_tot(ji,jj) + qsr_tot(ji,jj)
182	END DO
183	END DO
184
185	! In case we bypass open-water ice formation
186	IF( .NOT. ln_icedO ) qlead(:,:) = 0._wp
187	! In case we bypass growing/melting from top and bottom: we suppose ice is impermeable => ocean is isolated from atmosphere
188	IF( .NOT. ln_icedH ) THEN
189	hfx_in(:,:) = ( 1._wp - at_i_b(:,:) ) * ( qns_oce(:,:) + qsr_oce(:,:) ) + qemp_oce(:,:)
190	fhtur (:,:) = 0._wp
191	fhld (:,:) = 0._wp
192	ENDIF
193
194	! ---------------------------------------------------------------------
195	! Net heat flux on top of the ocean after ice thermo (1st step) [W.m-2]
196	! ---------------------------------------------------------------------
197	! First step here : non solar + precip - qlead - qturb
198	! Second step in icethd_dh : heat remaining if total melt (zq_rema)
199	! Third step in iceupdate.F90 : heat from ice-ocean mass exchange (zf_mass) + solar
200	hfx_out(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + qemp_oce(:,:) & ! Non solar heat flux received by the ocean
201	& - qlead(:,:) * r1_rdtice & ! heat flux taken from the ocean where there is open water ice formation
202	& - at_i (:,:) * fhtur(:,:) & ! heat flux taken by turbulence
203	& - at_i (:,:) * fhld(:,:) ! heat flux taken during bottom growth/melt
204	! (fhld should be 0 while bott growth)
205	!-------------------------------------------------------------------------------------------!
206	! Thermodynamic computation (only on grid points covered by ice) => loop over ice categories
207	!-------------------------------------------------------------------------------------------!
208	DO jl = 1, jpl
209
210	! select ice covered grid points
211	npti = 0 ; nptidx(:) = 0
212	DO jj = 1, jpj
213	DO ji = 1, jpi
214	IF ( a_i(ji,jj,jl) > epsi10 ) THEN
215	npti = npti + 1
216	nptidx(npti) = (jj - 1) * jpi + ji
217	ENDIF
218	END DO
219	END DO
220
221	IF( lk_mpp ) CALL mpp_ini_ice( npti , numout )
222
223	IF( npti > 0 ) THEN ! If there is no ice, do nothing.
224	!
225	CALL ice_thd_1d2d( jl, 1 ) ! --- Move to 1D arrays --- !
226	! ! --- & Change units of e_i, e_s from J/m2 to J/m3 --- !
227	!
228	s_i_new (1:npti) = 0._wp ; dh_s_tot (1:npti) = 0._wp ! --- some init --- ! (important to have them here)
229	dh_i_surf (1:npti) = 0._wp ; dh_i_bott(1:npti) = 0._wp
230	dh_snowice(1:npti) = 0._wp ; dh_i_sub (1:npti) = 0._wp ; dh_s_mlt(1:npti) = 0._wp
231	!
232	IF( ln_icedH ) THEN ! --- growing/melting --- !
233	CALL ice_thd_zdf ! Ice/Snow Temperature profile
234	CALL ice_thd_dh ! Ice/Snow thickness
235	CALL ice_thd_pnd ! Melt ponds formation
236	CALL ice_thd_ent( e_i_1d(1:npti,:) ) ! Ice enthalpy remapping
237	ENDIF
238	!
239	CALL ice_thd_sal( ln_icedS ) ! --- Ice salinity --- !
240	!
241	CALL ice_thd_temp ! --- temperature update --- !
242	!
243	!!gm please create a new logical (l_thd_lam or a better explicit name) set one for all in icestp.F90 module
244	!!gm l_thd_lam = ln_icedH .AND. ( ( nn_virtual_itd == 1 .OR. nn_virtual_itd == 4 ) .AND. jpl == 1 )
245	!!gm by the way, the different options associated with nn_virtual_itd =1 to 4 are quite impossible to identify
246	!!gm more comment to add when ready the namelist, with an explicit print in the ocean.output
247	IF( ln_icedH ) THEN
248	IF ( ( nn_virtual_itd == 1 .OR. nn_virtual_itd == 3 ) .AND. jpl == 1 ) THEN
249	CALL ice_thd_lam ! --- extra lateral melting if virtual_itd --- !
250	END IF
251	END IF
252	!
253	IF( ln_icedA ) CALL ice_thd_da ! --- lateral melting --- !
254	!
255	CALL ice_thd_1d2d( jl, 2 ) ! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
256	! ! --- & Move to 2D arrays --- !
257	!
258	IF( lk_mpp ) CALL mpp_comm_free( ncomm_ice ) !RB necessary ??
259	ENDIF
260	!
261	END DO
262	! update ice age (in case a_i changed, i.e. becomes 0 or lateral melting)
263	oa_i(:,:,:) = o_i(:,:,:) * a_i(:,:,:)
264
265	IF( ln_icediachk ) CALL ice_cons_hsm(1, 'icethd', rdiag_v, rdiag_s, rdiag_t, rdiag_fv, rdiag_fs, rdiag_ft)
266	!
267	CALL ice_var_zapsmall ! --- remove very small ice concentration (<1e-10) --- !
268	! ! & make sure at_i=SUM(a_i) & ato_i=1 where at_i=0
269	!
270	IF( jpl > 1 ) CALL ice_itd_rem( kt ) ! --- Transport ice between thickness categories --- !
271	!
272	IF( ln_icedO ) CALL ice_thd_do ! --- frazil ice growing in leads --- !
273	!
274	! controls
275	IF( ln_icectl ) CALL ice_prt (kt, iiceprt, jiceprt, 1, ' - ice thermodyn. - ') ! prints
276	IF( ln_ctl ) CALL ice_prt3D ('icethd') ! prints
277	IF( ln_timing ) CALL timing_stop('icethd') ! timing
278	!
279	END SUBROUTINE ice_thd
280
281
282	SUBROUTINE ice_thd_temp
283	!!-----------------------------------------------------------------------
284	!! * ROUTINE ice_thd_temp *
285	!!
286	!! ** Purpose : Computes sea ice temperature (Kelvin) from enthalpy
287	!!
288	!! ** Method : Formula (Bitz and Lipscomb, 1999)
289	!!-------------------------------------------------------------------
290	INTEGER :: ji, jk ! dummy loop indices
291	REAL(wp) :: ztmelts, zbbb, zccc ! local scalar
292	!!-------------------------------------------------------------------
293	! Recover ice temperature
294	DO jk = 1, nlay_i
295	DO ji = 1, npti
296	ztmelts = -tmut * sz_i_1d(ji,jk)
297	! Conversion q(S,T) -> T (second order equation)
298	zbbb = ( rcp - cpic ) * ztmelts + e_i_1d(ji,jk) * r1_rhoic - lfus
299	zccc = SQRT( MAX( zbbb * zbbb - 4._wp * cpic * lfus * ztmelts, 0._wp ) )
300	t_i_1d(ji,jk) = rt0 - ( zbbb + zccc ) * 0.5_wp * r1_cpic
301
302	! mask temperature
303	rswitch = 1._wp - MAX( 0._wp , SIGN( 1._wp , - h_i_1d(ji) ) )
304	t_i_1d(ji,jk) = rswitch * t_i_1d(ji,jk) + ( 1._wp - rswitch ) * rt0
305	END DO
306	END DO
307	!
308	END SUBROUTINE ice_thd_temp
309
310
311	SUBROUTINE ice_thd_lam
312	!!-----------------------------------------------------------------------
313	!! * ROUTINE ice_thd_lam *
314	!!
315	!! ** Purpose : Lateral melting in case virtual_itd
316	!! ( dA = A/2h dh )
317	!!-----------------------------------------------------------------------
318	INTEGER :: ji ! dummy loop indices
319	REAL(wp) :: zhi_bef ! ice thickness before thermo
320	REAL(wp) :: zdh_mel, zda_mel ! net melting
321	REAL(wp) :: zvi, zvs ! ice/snow volumes
322	!!-----------------------------------------------------------------------
323	!
324	DO ji = 1, npti
325	zdh_mel = MIN( 0._wp, dh_i_surf(ji) + dh_i_bott(ji) + dh_snowice(ji) + dh_i_sub(ji) )
326	IF( zdh_mel < 0._wp .AND. a_i_1d(ji) > 0._wp ) THEN
327	zvi = a_i_1d(ji) * h_i_1d(ji)
328	zvs = a_i_1d(ji) * h_s_1d(ji)
329	! lateral melting = concentration change
330	zhi_bef = h_i_1d(ji) - zdh_mel
331	rswitch = MAX( 0._wp , SIGN( 1._wp , zhi_bef - epsi20 ) )
332	zda_mel = rswitch * a_i_1d(ji) * zdh_mel / ( 2._wp * MAX( zhi_bef, epsi20 ) )
333	a_i_1d(ji) = MAX( epsi20, a_i_1d(ji) + zda_mel )
334	! adjust thickness
335	h_i_1d(ji) = zvi / a_i_1d(ji)
336	h_s_1d(ji) = zvs / a_i_1d(ji)
337	! retrieve total concentration
338	at_i_1d(ji) = a_i_1d(ji)
339	END IF
340	END DO
341	!
342	END SUBROUTINE ice_thd_lam
343
344
345	SUBROUTINE ice_thd_1d2d( kl, kn )
346	!!-----------------------------------------------------------------------
347	!! * ROUTINE ice_thd_1d2d *
348	!!
349	!! ** Purpose : move arrays from 1d to 2d and the reverse
350	!!-----------------------------------------------------------------------
351	INTEGER, INTENT(in) :: kl ! index of the ice category
352	INTEGER, INTENT(in) :: kn ! 1= from 2D to 1D ; 2= from 1D to 2D
353	!
354	INTEGER :: jk ! dummy loop indices
355	!!-----------------------------------------------------------------------
356	!
357	SELECT CASE( kn )
358	! !---------------------!
359	CASE( 1 ) !== from 2D to 1D ==!
360	! !---------------------!
361	CALL tab_2d_1d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i )
362	CALL tab_2d_1d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl) )
363	CALL tab_2d_1d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl) )
364	CALL tab_2d_1d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl) )
365	CALL tab_2d_1d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl) )
366	CALL tab_2d_1d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl) )
367	DO jk = 1, nlay_s
368	CALL tab_2d_1d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl) )
369	CALL tab_2d_1d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl) )
370	END DO
371	DO jk = 1, nlay_i
372	CALL tab_2d_1d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl) )
373	CALL tab_2d_1d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl) )
374	CALL tab_2d_1d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) )
375	END DO
376	CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
377	CALL tab_2d_1d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
378	CALL tab_2d_1d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
379	!
380	CALL tab_2d_1d( npti, nptidx(1:npti), qprec_ice_1d(1:npti), qprec_ice )
381	CALL tab_2d_1d( npti, nptidx(1:npti), qsr_ice_1d (1:npti), qsr_ice (:,:,kl) )
382	CALL tab_2d_1d( npti, nptidx(1:npti), qns_ice_1d (1:npti), qns_ice (:,:,kl) )
383	CALL tab_2d_1d( npti, nptidx(1:npti), ftr_ice_1d (1:npti), ftr_ice (:,:,kl) )
384	CALL tab_2d_1d( npti, nptidx(1:npti), evap_ice_1d (1:npti), evap_ice(:,:,kl) )
385	CALL tab_2d_1d( npti, nptidx(1:npti), dqns_ice_1d (1:npti), dqns_ice(:,:,kl) )
386	CALL tab_2d_1d( npti, nptidx(1:npti), t_bo_1d (1:npti), t_bo )
387	CALL tab_2d_1d( npti, nptidx(1:npti), sprecip_1d (1:npti), sprecip )
388	CALL tab_2d_1d( npti, nptidx(1:npti), fhtur_1d (1:npti), fhtur )
389	CALL tab_2d_1d( npti, nptidx(1:npti), fhld_1d (1:npti), fhld )
390
391	CALL tab_2d_1d( npti, nptidx(1:npti), qml_ice_1d (1:npti), qml_ice (:,:,kl) )
392	CALL tab_2d_1d( npti, nptidx(1:npti), qcn_ice_1d (1:npti), qcn_ice (:,:,kl) )
393	CALL tab_2d_1d( npti, nptidx(1:npti), qsr_ice_tr_1d(1:npti), qsr_ice_tr (:,:,kl) )
394	!
395	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
396	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum )
397	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sub_1d (1:npti), wfx_sub )
398	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub )
399	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub )
400	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub )
401	!
402	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog )
403	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom )
404	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum )
405	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni )
406	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res )
407	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr )
408	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam )
409	CALL tab_2d_1d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )
410	!
411	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog )
412	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom )
413	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum )
414	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni )
415	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri )
416	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res )
417	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub )
418	CALL tab_2d_1d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam )
419	!
420	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd )
421	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr )
422	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum )
423	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom )
424	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog )
425	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif )
426	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw )
427	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw )
428	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub )
429	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
430	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
431	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )
432	CALL tab_2d_1d( npti, nptidx(1:npti), hfx_out_1d (1:npti), hfx_out )
433	!
434	! SIMIP diagnostics
435	CALL tab_2d_1d( npti, nptidx(1:npti), diag_fc_bo_1d(1:npti), diag_fc_bo )
436	CALL tab_2d_1d( npti, nptidx(1:npti), diag_fc_su_1d(1:npti), diag_fc_su )
437	! ocean surface fields
438	CALL tab_2d_1d( npti, nptidx(1:npti), sst_1d(1:npti), sst_m )
439	CALL tab_2d_1d( npti, nptidx(1:npti), sss_1d(1:npti), sss_m )
440
441	! --- Change units of e_i, e_s from J/m2 to J/m3 --- !
442	DO jk = 1, nlay_i
443	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
444	END DO
445	DO jk = 1, nlay_s
446	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
447	END DO
448	!
449	! !---------------------!
450	CASE( 2 ) !== from 1D to 2D ==!
451	! !---------------------!
452	! --- Change units of e_i, e_s from J/m3 to J/m2 --- !
453	DO jk = 1, nlay_i
454	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
455	END DO
456	DO jk = 1, nlay_s
457	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
458	END DO
459	!
460	! Change thickness to volume (replaces routine ice_var_eqv2glo)
461	v_i_1d (1:npti) = h_i_1d (1:npti) * a_i_1d (1:npti)
462	v_s_1d (1:npti) = h_s_1d (1:npti) * a_i_1d (1:npti)
463	sv_i_1d(1:npti) = s_i_1d (1:npti) * v_i_1d (1:npti)
464	v_ip_1d(1:npti) = h_ip_1d(1:npti) * a_ip_1d(1:npti)
465
466	CALL tab_1d_2d( npti, nptidx(1:npti), at_i_1d(1:npti), at_i )
467	CALL tab_1d_2d( npti, nptidx(1:npti), a_i_1d (1:npti), a_i (:,:,kl) )
468	CALL tab_1d_2d( npti, nptidx(1:npti), h_i_1d (1:npti), h_i (:,:,kl) )
469	CALL tab_1d_2d( npti, nptidx(1:npti), h_s_1d (1:npti), h_s (:,:,kl) )
470	CALL tab_1d_2d( npti, nptidx(1:npti), t_su_1d(1:npti), t_su(:,:,kl) )
471	CALL tab_1d_2d( npti, nptidx(1:npti), s_i_1d (1:npti), s_i (:,:,kl) )
472	DO jk = 1, nlay_s
473	CALL tab_1d_2d( npti, nptidx(1:npti), t_s_1d(1:npti,jk), t_s(:,:,jk,kl) )
474	CALL tab_1d_2d( npti, nptidx(1:npti), e_s_1d(1:npti,jk), e_s(:,:,jk,kl) )
475	END DO
476	DO jk = 1, nlay_i
477	CALL tab_1d_2d( npti, nptidx(1:npti), t_i_1d (1:npti,jk), t_i (:,:,jk,kl) )
478	CALL tab_1d_2d( npti, nptidx(1:npti), e_i_1d (1:npti,jk), e_i (:,:,jk,kl) )
479	CALL tab_1d_2d( npti, nptidx(1:npti), sz_i_1d(1:npti,jk), sz_i(:,:,jk,kl) )
480	END DO
481	CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_1d (1:npti), a_ip (:,:,kl) )
482	CALL tab_1d_2d( npti, nptidx(1:npti), h_ip_1d (1:npti), h_ip (:,:,kl) )
483	CALL tab_1d_2d( npti, nptidx(1:npti), a_ip_frac_1d(1:npti), a_ip_frac(:,:,kl) )
484	!
485	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sni_1d(1:npti), wfx_snw_sni )
486	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sum_1d(1:npti), wfx_snw_sum )
487	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sub_1d (1:npti), wfx_sub )
488	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_snw_sub_1d(1:npti), wfx_snw_sub )
489	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_ice_sub_1d(1:npti), wfx_ice_sub )
490	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_err_sub_1d(1:npti), wfx_err_sub )
491	!
492	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bog_1d (1:npti), wfx_bog )
493	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_bom_1d (1:npti), wfx_bom )
494	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sum_1d (1:npti), wfx_sum )
495	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_sni_1d (1:npti), wfx_sni )
496	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_res_1d (1:npti), wfx_res )
497	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_spr_1d (1:npti), wfx_spr )
498	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_lam_1d (1:npti), wfx_lam )
499	CALL tab_1d_2d( npti, nptidx(1:npti), wfx_pnd_1d (1:npti), wfx_pnd )
500	!
501	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bog_1d (1:npti), sfx_bog )
502	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bom_1d (1:npti), sfx_bom )
503	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sum_1d (1:npti), sfx_sum )
504	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sni_1d (1:npti), sfx_sni )
505	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_bri_1d (1:npti), sfx_bri )
506	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_res_1d (1:npti), sfx_res )
507	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_sub_1d (1:npti), sfx_sub )
508	CALL tab_1d_2d( npti, nptidx(1:npti), sfx_lam_1d (1:npti), sfx_lam )
509	!
510	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_thd_1d (1:npti), hfx_thd )
511	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_spr_1d (1:npti), hfx_spr )
512	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sum_1d (1:npti), hfx_sum )
513	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bom_1d (1:npti), hfx_bom )
514	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_bog_1d (1:npti), hfx_bog )
515	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_dif_1d (1:npti), hfx_dif )
516	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_opw_1d (1:npti), hfx_opw )
517	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_snw_1d (1:npti), hfx_snw )
518	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_sub_1d (1:npti), hfx_sub )
519	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_res_1d (1:npti), hfx_res )
520	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_dif_1d(1:npti), hfx_err_dif )
521	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_err_rem_1d(1:npti), hfx_err_rem )
522	CALL tab_1d_2d( npti, nptidx(1:npti), hfx_out_1d (1:npti), hfx_out )
523	!
524	CALL tab_1d_2d( npti, nptidx(1:npti), qns_ice_1d(1:npti), qns_ice(:,:,kl) )
525	CALL tab_1d_2d( npti, nptidx(1:npti), ftr_ice_1d(1:npti), ftr_ice(:,:,kl) )
526	! effective conductivity and 1st layer temperature (for Jules coupling)
527	CALL tab_1d_2d( npti, nptidx(1:npti), cnd_ice_1d(1:npti), cnd_ice(:,:,kl) )
528	CALL tab_1d_2d( npti, nptidx(1:npti), t1_ice_1d (1:npti), t1_ice (:,:,kl) )
529	! SIMIP diagnostics
530	CALL tab_1d_2d( npti, nptidx(1:npti), t_si_1d (1:npti), t_si(:,:,kl) )
531	CALL tab_1d_2d( npti, nptidx(1:npti), diag_fc_bo_1d(1:npti), diag_fc_bo )
532	CALL tab_1d_2d( npti, nptidx(1:npti), diag_fc_su_1d(1:npti), diag_fc_su )
533	! extensive variables
534	CALL tab_1d_2d( npti, nptidx(1:npti), v_i_1d (1:npti), v_i (:,:,kl) )
535	CALL tab_1d_2d( npti, nptidx(1:npti), v_s_1d (1:npti), v_s (:,:,kl) )
536	CALL tab_1d_2d( npti, nptidx(1:npti), sv_i_1d(1:npti), sv_i(:,:,kl) )
537	CALL tab_1d_2d( npti, nptidx(1:npti), v_ip_1d(1:npti), v_ip(:,:,kl) )
538	!
539	END SELECT
540	!
541	END SUBROUTINE ice_thd_1d2d
542
543
544	SUBROUTINE ice_thd_init
545	!!-------------------------------------------------------------------
546	!! * ROUTINE ice_thd_init *
547	!!
548	!! ** Purpose : Physical constants and parameters associated with
549	!! ice thermodynamics
550	!!
551	!! ** Method : Read the namthd namelist and check the parameters
552	!! called at the first timestep (nit000)
553	!!
554	!! ** input : Namelist namthd
555	!!-------------------------------------------------------------------
556	INTEGER :: ios ! Local integer output status for namelist read
557	!!
558	NAMELIST/namthd/ ln_icedH, ln_icedA, ln_icedO, ln_icedS
559	!!-------------------------------------------------------------------
560	!
561	REWIND( numnam_ice_ref ) ! Namelist namthd in reference namelist : Ice thermodynamics
562	READ ( numnam_ice_ref, namthd, IOSTAT = ios, ERR = 901)
563	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namthd in reference namelist', lwp )
564	REWIND( numnam_ice_cfg ) ! Namelist namthd in configuration namelist : Ice thermodynamics
565	READ ( numnam_ice_cfg, namthd, IOSTAT = ios, ERR = 902 )
566	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namthd in configuration namelist', lwp )
567	IF(lwm) WRITE( numoni, namthd )
568	!
569	IF(lwp) THEN ! control print
570	WRITE(numout,*)
571	WRITE(numout,*) 'ice_thd_init: Ice Thermodynamics'
572	WRITE(numout,*) '~~~~~~~~~~~~'
573	WRITE(numout,*) ' Namelist namthd:'
574	WRITE(numout,*) ' activate ice thick change from top/bot (T) or not (F) ln_icedH = ', ln_icedH
575	WRITE(numout,*) ' activate lateral melting (T) or not (F) ln_icedA = ', ln_icedA
576	WRITE(numout,*) ' activate ice growth in open-water (T) or not (F) ln_icedO = ', ln_icedO
577	WRITE(numout,*) ' activate gravity drainage and flushing (T) or not (F) ln_icedS = ', ln_icedS
578	ENDIF
579	!
580	CALL ice_thd_zdf_init ! set ice heat diffusion parameters
581	IF( ln_icedA ) CALL ice_thd_da_init ! set ice lateral melting parameters
582	IF( ln_icedO ) CALL ice_thd_do_init ! set ice growth in open water parameters
583	CALL ice_thd_sal_init ! set ice salinity parameters
584	CALL ice_thd_pnd_init ! set melt ponds parameters
585	!
586	END SUBROUTINE ice_thd_init
587
588	#else
589	!!----------------------------------------------------------------------
590	!! Default option Dummy module NO SI3 sea-ice model
591	!!----------------------------------------------------------------------
592	#endif
593
594	!!======================================================================
595	END MODULE icethd

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

Download in other formats: