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/releases/r4.0/r4.0-HEAD/src/ICE – NEMO

Context Navigation

source: NEMO/releases/r4.0/r4.0-HEAD/src/ICE/icethd.F90 @ 14885

Last change on this file since 14885 was 14885, checked in by clem, 3 years ago
4.0-HEAD ICE: the diagnostic of heat flux for ice surface melt was not outputed because of initialization problem
Property svn:keywords set to `Id`
File size: 36.5 KB

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

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

Download in other formats: