Context Navigation

icethd.F90 @ 10993

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

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: NEMO/releases/release-4.0/src/ICE/icethd.F90 @ 10993

Download in other formats: