Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

surf_land_mod.F90

Last change on this file was 4528, checked in by evignon, 13 months ago
fix issue in phylmdiso from commit 4526 in phylmd
File size: 15.4 KB

Line
1	!
2	MODULE surf_land_mod
3
4	IMPLICIT NONE
5
6	CONTAINS
7	!
8	!****************************************************************************************
9	!
10	SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
11	rlon, rlat, yrmu0, &
12	debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, &
13	tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, precip_bs, temp_air, spechum, &
14	AcoefH, AcoefQ, BcoefH, BcoefQ, &
15	AcoefU, AcoefV, BcoefU, BcoefV, &
16	pref, u1, v1, gustiness, rugoro, pctsrf, &
17	lwdown_m, q2m, t2m, &
18	snow, qsol, agesno, tsoil, &
19	z0m, z0h, SFRWL, alb_dir_new, alb_dif_new, evap, fluxsens, fluxlat, fluxbs, &
20	qsurf, tsurf_new, dflux_s, dflux_l, &
21	flux_u1, flux_v1 , &
22	veget,lai,height &
23	#ifdef ISO
24	,xtprecip_rain, xtprecip_snow,xtspechum, &
25	xtsnow, xtsol,xtevap,h1, &
26	runoff_diag,xtrunoff_diag,Rland_ice &
27	#endif
28	)
29
30	USE dimphy
31	USE surface_data, ONLY : ok_veget
32	USE carbon_cycle_mod
33
34	! See comments in each module surf_land_orchidee_xxx for compatiblity with ORCHIDEE
35	#ifdef ORCHIDEE_NOOPENMP
36	! Compilation with cpp key ORCHIDEE NOOPENMP
37	USE surf_land_orchidee_noopenmp_mod
38	#else
39	#if ORCHIDEE_NOZ0H
40	! Compilation with cpp key ORCHIDEE NOZ0H
41	USE surf_land_orchidee_noz0h_mod
42	#else
43	#if ORCHIDEE_NOFREIN
44	! Compilation with cpp key ORCHIDEE_NOFREIN
45	USE surf_land_orchidee_nofrein_mod
46	#else
47	#if ORCHIDEE_NOUNSTRUCT
48	! Compilation with cpp key ORCHIDEE_NOUNSTRUCT
49	USE surf_land_orchidee_nounstruct_mod
50	#else
51	#if ORCHIDEE_NOLIC
52	! Compilation with cpp key ORCHIDEE_NOLIC
53	USE surf_land_orchidee_nolic_mod
54	#else
55	! Default version#else
56	USE surf_land_orchidee_mod
57	#endif
58	#endif
59	#endif
60	#endif
61	#endif
62
63	USE surf_land_bucket_mod
64	USE calcul_fluxs_mod
65	USE indice_sol_mod
66	#ifdef ISO
67	use infotrac_phy, ONLY: ntiso,niso
68	use isotopes_mod, ONLY: nudge_qsol, iso_eau
69	#ifdef ISOVERIF
70	use isotopes_verif_mod
71	#endif
72	#endif
73
74	USE print_control_mod, ONLY: lunout
75
76	INCLUDE "dimsoil.h"
77	INCLUDE "YOMCST.h"
78	INCLUDE "clesphys.h"
79	INCLUDE "dimpft.h"
80
81	! Input variables
82	!****************************************************************************************
83	INTEGER, INTENT(IN) :: itime, jour, knon
84	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
85	REAL, INTENT(IN) :: date0
86	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
87	REAL, DIMENSION(klon), INTENT(IN) :: yrmu0 ! cosine of solar zenith angle
88	LOGICAL, INTENT(IN) :: debut, lafin
89	REAL, INTENT(IN) :: dtime
90	REAL, DIMENSION(klon), INTENT(IN) :: zlev, ccanopy
91	REAL, DIMENSION(klon), INTENT(IN) :: swnet, lwnet
92	REAL, DIMENSION(klon), INTENT(IN) :: albedo ! albedo for whole short-wave interval
93	REAL, DIMENSION(klon), INTENT(IN) :: tsurf
94	REAL, DIMENSION(klon), INTENT(IN) :: p1lay
95	REAL, DIMENSION(klon), INTENT(IN) :: cdragh, cdragm
96	REAL, DIMENSION(klon), INTENT(IN) :: precip_rain, precip_snow, precip_bs
97	REAL, DIMENSION(klon), INTENT(IN) :: temp_air, spechum
98	REAL, DIMENSION(klon), INTENT(IN) :: AcoefH, AcoefQ, BcoefH, BcoefQ
99	REAL, DIMENSION(klon), INTENT(IN) :: AcoefU, AcoefV, BcoefU, BcoefV
100	REAL, DIMENSION(klon), INTENT(IN) :: pref ! pressure reference
101	REAL, DIMENSION(klon), INTENT(IN) :: u1, v1, gustiness
102	REAL, DIMENSION(klon), INTENT(IN) :: rugoro
103	REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
104	REAL, DIMENSION(klon), INTENT(IN) :: lwdown_m ! downwelling longwave radiation at mean surface
105	! corresponds to previous sollwdown
106	REAL, DIMENSION(klon), INTENT(IN) :: q2m, t2m
107	#ifdef ISO
108	REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtprecip_rain, xtprecip_snow
109	REAL, DIMENSION(ntiso,klon), INTENT(IN) :: xtspechum
110	#endif
111
112	! In/Output variables
113	!****************************************************************************************
114	REAL, DIMENSION(klon), INTENT(INOUT) :: snow, qsol
115	REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
116	REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
117	#ifdef ISO
118	REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsnow, xtsol
119	#endif
120
121	! Output variables
122	!****************************************************************************************
123	REAL, DIMENSION(klon), INTENT(OUT) :: z0m, z0h
124	!albedo SB >>>
125	! REAL, DIMENSION(klon), INTENT(OUT) :: alb1_new ! albdeo for shortwave interval 1(visible)
126	! REAL, DIMENSION(klon), INTENT(OUT) :: alb2_new ! albedo for shortwave interval 2(near infrared)
127	REAL, DIMENSION(6), INTENT(IN) :: SFRWL
128	REAL, DIMENSION(klon,nsw), INTENT(OUT) :: alb_dir_new,alb_dif_new
129	!albedo SB <<<
130	REAL, DIMENSION(klon), INTENT(OUT) :: evap
131	REAL, DIMENSION(klon), INTENT(OUT) :: fluxsens, fluxlat, fluxbs
132	REAL, DIMENSION(klon), INTENT(OUT) :: qsurf
133	REAL, DIMENSION(klon), INTENT(OUT) :: tsurf_new
134	REAL, DIMENSION(klon), INTENT(OUT) :: dflux_s, dflux_l
135	REAL, DIMENSION(klon), INTENT(OUT) :: flux_u1, flux_v1 ! flux for U and V at first model level
136	REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: veget,lai
137	REAL, DIMENSION(klon,nvm_lmdz), INTENT(OUT) :: height
138	#ifdef ISO
139	REAL, DIMENSION(ntiso,klon), INTENT(OUT) :: xtevap
140	REAL, DIMENSION(klon), INTENT(OUT) :: h1
141	REAL, DIMENSION(niso,klon), INTENT(OUT) :: xtrunoff_diag
142	REAL, DIMENSION(klon), INTENT(OUT) :: runoff_diag
143	REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice
144	#endif
145
146	! Local variables
147	!****************************************************************************************
148	REAL, DIMENSION(klon) :: p1lay_tmp
149	REAL, DIMENSION(klon) :: pref_tmp
150	REAL, DIMENSION(klon) :: swdown ! downwelling shortwave radiation at land surface
151	REAL, DIMENSION(klon) :: epot_air ! potential air temperature
152	REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
153	REAL, DIMENSION(klon) :: u0, v0 ! surface speed
154	REAL, DIMENSION(klon) :: precip_totsnow ! total solid precip
155	INTEGER :: i
156
157	!albedo SB >>>
158	REAL, DIMENSION(klon) :: alb1_new,alb2_new
159	!albedo SB <<<
160
161	#ifdef ISO
162	real, parameter :: t_coup = 273.15
163	real, dimension(klon) :: fqfonte_diag
164	real, dimension(klon) :: snow_evap_diag
165	real, dimension(klon) :: fqcalving_diag
166	integer :: ixt
167	#endif
168
169	!****************************************************************************************
170	!Total solid precip
171
172	IF (ok_bs) THEN
173	precip_totsnow(:)=precip_snow(:)+precip_bs(:)
174	ELSE
175	precip_totsnow(:)=precip_snow(:)
176	ENDIF
177	!****************************************************************************************
178	#ifdef ISO
179	#ifdef ISOVERIF
180	! write(,) 'surf_land_mod 162'
181	do i=1,knon
182	if (iso_eau.gt.0) then
183	call iso_verif_egalite_choix(precip_snow(i), &
184	& xtprecip_snow(iso_eau,i),'surf_land_mod 129', &
185	& errmax,errmaxrel)
186	call iso_verif_egalite_choix(qsol(i), &
187	& xtsol(iso_eau,i),'surf_land_mod 139', &
188	& errmax,errmaxrel)
189	endif
190	enddo
191	#endif
192	#ifdef ISOVERIF
193	! write(,) 'surf_land 169: ok_veget=',ok_veget
194	do i=1,knon
195	do ixt=1,ntiso
196	call iso_verif_noNaN(xtprecip_snow(ixt,i),'surf_land 146')
197	enddo
198	enddo
199	#endif
200	#endif
201
202
203	!****************************************************************************************
204	! Choice between call to vegetation model (ok_veget=true) or simple calculation below
205	!
206	!****************************************************************************************
207	IF (ok_veget) THEN
208	!****************************************************************************************
209	! Call model sechiba in model ORCHIDEE
210	!
211	!****************************************************************************************
212	p1lay_tmp(:) = 0.0
213	pref_tmp(:) = 0.0
214	p1lay_tmp(1:knon) = p1lay(1:knon)/100.
215	pref_tmp(1:knon) = pref(1:knon)/100.
216	!
217	!* Calculate incoming flux for SW and LW interval: swdown
218	!
219	swdown(:) = 0.0
220	DO i = 1, knon
221	swdown(i) = swnet(i)/(1-albedo(i))
222	END DO
223	!
224	!* Calculate potential air temperature
225	!
226	epot_air(:) = 0.0
227	DO i = 1, knon
228	epot_air(i) = RCPDtemp_air(i)(pref(i)/p1lay(i))**RKAPPA
229	END DO
230
231	#ifdef ISO
232	CALL abort_gcm('surf_land_mod 220','isos pas prevus dans orchidee',1)
233	#endif
234	! temporary for keeping same results using lwdown_m instead of lwdown
235	CALL surf_land_orchidee(itime, dtime, date0, knon, &
236	knindex, rlon, rlat, yrmu0, pctsrf, &
237	debut, lafin, &
238	zlev, u1, v1, gustiness, temp_air, spechum, epot_air, ccanopy, &
239	cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, &
240	precip_rain, precip_totsnow, lwdown_m, swnet, swdown, &
241	pref_tmp, q2m, t2m, &
242	evap, fluxsens, fluxlat, &
243	tsol_rad, tsurf_new, alb1_new, alb2_new, &
244	emis_new, z0m, z0h, qsurf, &
245	veget, lai, height &
246	!#ifdef ISO
247	! , xtprecip_rain, xtprecip_snow, xtspechum, xtevap &
248	!#endif
249	)
250
251	#ifdef ISO
252	#ifdef ISOVERIF
253	write(,) 'surf_land 193: apres surf_land_orchidee'
254	do i=1,knon
255	if (iso_eau.gt.0) then
256	call iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), &
257	& 'surf_land 197',errmax,errmaxrel)
258	endif !if (iso_eau.gt.0) then
259	enddo !do i=1,knon
260	#endif
261	#endif
262	!
263	!* Add contribution of relief to surface roughness
264	!
265	DO i=1,knon
266	z0m(i) = MAX(1.5e-05,SQRT(z0m(i)2 + rugoro(i)2))
267	ENDDO
268
269	ELSE ! not ok_veget
270	!****************************************************************************************
271	! No extern vegetation model choosen, call simple bucket calculations instead.
272	!
273	!****************************************************************************************
274	#ifdef ISO
275	#ifdef ISOVERIF
276	! write(,) 'surf_land 247'
277	call iso_verif_egalite_vect1D( &
278	& xtsnow,snow,'surf_land_mod 207',niso,klon)
279	#endif
280	#endif
281
282	#ifdef ISO
283	if (nudge_qsol.eq.1) then
284	call surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
285	endif
286	!write(,) 'surf_land 258'
287	#endif
288	CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
289	tsurf, p1lay, cdragh, precip_rain, precip_totsnow, temp_air, &
290	spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, &
291	u1, v1, gustiness, rugoro, swnet, lwnet, &
292	snow, qsol, agesno, tsoil, &
293	qsurf, z0m, alb1_new, alb2_new, evap, &
294	fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l &
295	#ifdef ISO
296	,xtprecip_rain, xtprecip_snow,xtspechum, &
297	xtsnow, xtsol,xtevap,h1, &
298	& runoff_diag, xtrunoff_diag,Rland_ice &
299	#endif
300	& )
301	z0h(1:knon)=z0m(1:knon) ! En attendant mieux
302
303	ENDIF ! ok_veget
304
305	! blowing snow not treated yet over land
306	fluxbs(:)=0.
307	!****************************************************************************************
308	! Calculation for all land models
309	! - Flux calculation at first modele level for U and V
310	!****************************************************************************************
311	! Suppose zero surface speed
312	u0(:)=0.0
313	v0(:)=0.0
314	CALL calcul_flux_wind(knon, dtime, &
315	u0, v0, u1, v1, gustiness, cdragm, &
316	AcoefU, AcoefV, BcoefU, BcoefV, &
317	p1lay, temp_air, &
318	flux_u1, flux_v1)
319
320	#ifdef ISO
321	#ifdef ISOVERIF
322	! write(,) 'surf_land 237: sortie'
323	do i=1,knon
324	if (iso_eau.gt.0) then
325	call iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), &
326	& 'surf_land 241',errmax,errmaxrel)
327	endif !if (iso_eau.gt.0) then
328	enddo !do i=1,knon
329	#endif
330	#endif
331
332	!albedo SB >>>
333	SELECT CASE(NSW)
334	CASE(2)
335	alb_dir_new(1:knon,1)=alb1_new(1:knon)
336	alb_dir_new(1:knon,2)=alb2_new(1:knon)
337	CASE(4)
338	alb_dir_new(1:knon,1)=alb1_new(1:knon)
339	alb_dir_new(1:knon,2)=alb2_new(1:knon)
340	alb_dir_new(1:knon,3)=alb2_new(1:knon)
341	alb_dir_new(1:knon,4)=alb2_new(1:knon)
342	CASE(6)
343	alb_dir_new(1:knon,1)=alb1_new(1:knon)
344	alb_dir_new(1:knon,2)=alb1_new(1:knon)
345	alb_dir_new(1:knon,3)=alb1_new(1:knon)
346	alb_dir_new(1:knon,4)=alb2_new(1:knon)
347	alb_dir_new(1:knon,5)=alb2_new(1:knon)
348	alb_dir_new(1:knon,6)=alb2_new(1:knon)
349	END SELECT
350
351	alb_dif_new=alb_dir_new
352	!albedo SB <<<
353
354	END SUBROUTINE surf_land
355
356
357	#ifdef ISO
358	SUBROUTINE surf_land_nudge_qsol(knon,rlat,rlon,qsol,xtsol,knindex)
359
360	USE dimphy
361	USE infotrac_phy, ONLY: niso
362	use isotopes_mod, ONLY: region_nudge_qsol
363	INTEGER, INTENT(IN) :: knon
364	REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
365	REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
366	INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
367	REAL, DIMENSION(niso,klon), INTENT(INOUT) :: xtsol
368	real lat_min_nudge_qsol,lat_max_nudge_qsol
369	real lon_min_nudge_qsol,lon_max_nudge_qsol
370	integer i,ixt
371	real qsol_new
372
373	if (region_nudge_qsol.eq.1) then
374	! Aamzonie du Sud
375	lat_min_nudge_qsol=-15.0
376	lat_max_nudge_qsol=-5.0
377	lon_min_nudge_qsol=-70.0
378	lon_max_nudge_qsol=-50.0
379	else if (region_nudge_qsol.eq.2) then
380	! Aamzonie du Nord
381	lat_min_nudge_qsol=-5.0
382	lat_max_nudge_qsol=5.0
383	lon_min_nudge_qsol=-70.0
384	lon_max_nudge_qsol=-50.0
385	else
386	write(,) 'surf_land 298: cas pas prevu'
387	write(,) 'region_nudge_qsol=',region_nudge_qsol
388	stop
389	endif
390
391	! write(,) 'surf_land 314: knon=',knon
392	! write(,) 'rlat=',rlat
393	! write(,) 'rlon=',rlon
394	! write(,) 'region_nudge_qsol=',region_nudge_qsol
395
396	do i=1,knon
397	if ((rlat(knindex(i)).ge.lat_min_nudge_qsol).and. &
398	& (rlat(knindex(i)).le.lat_max_nudge_qsol).and. &
399	& (rlon(knindex(i)).ge.lon_min_nudge_qsol).and. &
400	& (rlon(knindex(i)).le.lon_max_nudge_qsol)) then
401	! write(,) 'surf_land 324: bon domaine: rlat,rlon,qsol=', &
402	! & rlat(knindex(i)),rlon(knindex(i)),qsol(knindex(i))
403	qsol_new=qsol(i)
404	if (region_nudge_qsol.eq.1) then
405	qsol_new=max(qsol(i),50.0)
406	else if (region_nudge_qsol.eq.2) then
407	qsol_new=max(qsol(i),120.0)
408	else !if (region_nudge_qsol.eq.1) then
409	write(,) 'surf_land 317: cas pas prevu'
410	write(,) 'region_nudge_qsol=',region_nudge_qsol
411	stop
412	endif !if (region_nudge_qsol.eq.1) then
413	if (qsol(i).gt.0.0) then
414	do ixt=1,niso
415	xtsol(ixt,i)=xtsol(ixt,i)*qsol_new/qsol(i)
416	enddo
417	else !if (qsol(i).gt.0.0) then
418	do ixt=1,niso
419	xtsol(ixt,i)=0.0
420	enddo
421	endif !if (qsol(i).gt.0.0) then
422	qsol(i)=qsol_new
423	write(,) 'surf_land 346: qsol_new=',qsol(i)
424	endif ! if ((rlat(i).ge.lat_min_nudge_qsol).and.
425	enddo !do i=1,knon
426
427	END SUBROUTINE surf_land_nudge_qsol
428	#endif
429
430	!
431	!****************************************************************************************
432	!
433	END MODULE surf_land_mod
434	!
435	!****************************************************************************************
436	!

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

Download in other formats:

Original Format