Context Navigation

icethd.F90 @ 12475

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

Download in other formats: