Context Navigation

cdrag_mod.f90 @ 5873

Last change on this file since 5873 was 5873, checked in by yann meurdesoif, 3 days ago
GPU port : remove block construct that are incompatible with GPU-morphosis YM
Property svn:executable set to ``* Property svn:keywords set to `Id`
File size: 25.7 KB

Line
1	!
2	!$Id: cdrag_mod.f90 5873 2025-11-19 10:01:03Z ymeurdesoif $
3	!
4	!
5	MODULE cdrag_mod
6	!
7	! This module contains some procedures for calculation of the cdrag
8	! coefficients for turbulent diffusion at surface
9	!
10	IMPLICIT NONE
11
12	CONTAINS
13	!
14	!****************************************************************************************
15	!
16	!r original routine svn3623
17	!
18	SUBROUTINE cdrag(knon, nsrf, &
19	speed, t1, q1, zgeop1, &
20	psol, pblh, tsurf, qsurf, z0m, z0h, &
21	ri_in, iri_in, &
22	cdm, cdh, zri, pref, prain, tsol , pat1)
23
24	USE coare_cp_mod, ONLY: coare_cp
25	USE coare30_flux_cnrm_mod, ONLY: coare30_flux_cnrm
26	USE indice_sol_mod
27	USE print_control_mod, ONLY: lunout, prt_level
28	USE ioipsl_getin_p_mod, ONLY : getin_p
29	USE lmdz_atke_turbulence_ini, ONLY : smmin, ric, cinf, cepsilon, pr_slope, pr_asym, pr_neut
30	USE yomcst_mod_h
31	USE clesphys_mod_h
32	USE yoethf_mod_h
33	IMPLICIT NONE
34	! ================================================================= c
35	!
36	! Objet : calcul des cdrags pour le moment (pcfm) et
37	! les flux de chaleur sensible et latente (pcfh) d'apr??s
38	! Louis 1982, Louis 1979, King et al 2001
39	! ou Zilitinkevich et al 2002 pour les cas stables, Louis 1979
40	! et 1982 pour les cas instables
41	!
42	! Modified history:
43	! writting on the 20/05/2016
44	! modified on the 13/12/2016 to be adapted to LMDZ6
45	!
46	! References:
47	! Louis, J. F., 1979: A parametric model of vertical eddy fluxes in the
48	! atmosphere. Boundary-Layer Meteorology. 01/1979; 17(2):187-202.
49	! Louis, J. F., Tiedtke, M. and Geleyn, J. F., 1982: `A short history of the
50	! operational PBL parametrization at ECMWF'. Workshop on boundary layer
51	! parametrization, November 1981, ECMWF, Reading, England.
52	! Page: 19. Equations in Table 1.
53	! Mascart P, Noilhan J, Giordani H 1995.A MODIFIED PARAMETERIZATION OF FLUX-PROFILE RELATIONSHIPS
54	! IN THE SURFACE LAYER USING DIFFERENT ROUGHNESS LENGTH VALUES FOR HEAT AND MOMENTUM
55	! Boundary-Layer Meteorology 72: 331-344
56	! Anton Beljaars. May 1992. The parametrization of the planetary boundary layer.
57	! European Centre for Medium-Range Weather Forecasts.
58	! Equations: 110-113. Page 40.
59	! Miller,M.J., A.C.M.Beljaars, T.N.Palmer. 1992. The sensitivity of the ECMWF
60	! model to the parameterization of evaporation from the tropical oceans. J.
61	! Climate, 5:418-434.
62	! King J.C, Connolley, W.M ad Derbyshire S.H. 2001, Sensitivity of Modelled Antarctic climate
63	! to surface and boundary-layer flux parametrizations
64	! QJRMS, 127, pp 779-794
65	!
66	! ================================================================= c
67	! ================================================================= c
68	! On choisit le couple de fonctions de correction avec deux flags:
69	! Un pour les cas instables, un autre pour les cas stables
70	!
71	! iflag_corr_insta:
72	! 1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
73	! 2: Louis 1982
74	! 3: Laurent Li
75	!
76	! iflag_corr_sta:
77	! 1: Louis 1979 avec les modifications de Mascart 1995 (z0/= z0h)
78	! 2: Louis 1982
79	! 3: Laurent Li
80	! 4: King 2001 (SHARP)
81	! 5: MO 1st order theory (allow collapse of turbulence)
82	!
83	!
84	!*****************************************************************
85	! Parametres d'entree
86	!*****************************************************************
87
88	INTEGER, INTENT(IN) :: knon, nsrf ! nombre de points de grille sur l'horizontal + type de surface
89	REAL, DIMENSION(knon), INTENT(IN) :: speed ! module du vent au 1er niveau du modele
90	REAL, DIMENSION(knon), INTENT(IN) :: zgeop1 ! geopotentiel au 1er niveau du modele
91	REAL, DIMENSION(knon), INTENT(IN) :: tsurf ! Surface temperature (K)
92	REAL, DIMENSION(knon), INTENT(IN) :: qsurf ! Surface humidity (Kg/Kg)
93	REAL, DIMENSION(knon), INTENT(INOUT) :: z0m, z0h ! Rugosity at surface (m)
94	REAL, DIMENSION(knon), INTENT(IN) :: ri_in ! Input Richardson 1st layer for first guess calculations of screen var.
95	INTEGER, INTENT(IN) :: iri_in! iflag to activate cdrag calculation using ri1
96	REAL, DIMENSION(knon), INTENT(IN) :: t1 ! Temperature au premier niveau (K)
97	REAL, DIMENSION(knon), INTENT(IN) :: q1 ! humidite specifique au premier niveau (kg/kg)
98	REAL, DIMENSION(knon), INTENT(IN) :: psol ! pression au sol
99
100	!------------------ Rajout pour COARE (OT2018) --------------------
101	REAL, DIMENSION(knon), INTENT(INOUT) :: pblh !hauteur de CL
102	REAL, DIMENSION(knon), INTENT(IN) :: prain !rapport au precipitation
103	REAL, DIMENSION(knon), INTENT(IN) :: tsol !SST imposé sur la surface oceanique
104	REAL, DIMENSION(knon), INTENT(IN) :: pat1 !pression premier lev
105
106
107
108	! Parametres de sortie
109	!******************************************************************
110	REAL, DIMENSION(knon), INTENT(OUT) :: cdm ! Drag coefficient for momentum
111	REAL, DIMENSION(knon), INTENT(OUT) :: cdh ! Drag coefficient for heat flux
112	REAL, DIMENSION(knon), INTENT(OUT) :: zri ! Richardson number
113	REAL, DIMENSION(knon), INTENT(INOUT) :: pref ! Pression au niveau zgeop/RG
114
115	! Variables Locales
116	!******************************************************************
117
118	REAL, PARAMETER :: CKAP=0.40, CKAPT=0.42
119	REAL CEPDU2
120	REAL ALPHA
121	REAL CB,CC,CD,C2,C3
122	REAL MU, CM, CH, B, CMstar, CHstar
123	REAL PM, PH, BPRIME
124	INTEGER ng_q1 ! Number of grids that q1 < 0.0
125	INTEGER ng_qsurf ! Number of grids that qsurf < 0.0
126	INTEGER i, k
127	REAL zdu2, ztsolv
128	REAL ztvd, zscf
129	REAL zucf, zcr
130	REAL, DIMENSION(knon) :: FM, FH ! stability functions
131	REAL, DIMENSION(knon) :: cdmn, cdhn ! Drag coefficient in neutral conditions
132	REAL zzzcd
133	REAL, DIMENSION(knon) :: sm, prandtl ! Stability function from atke turbulence scheme
134	REAL ri0, ri1, cn ! to have dimensionless term in sm and prandtl
135
136	!------------------ Rajout (OT2018) --------------------
137	!------------------ Rajout pour les appelles BULK (OT) --------------------
138	REAL, DIMENSION(knon,2) :: rugos_itm
139	REAL, DIMENSION(knon,2) :: rugos_ith
140	REAL, PARAMETER :: tol_it_rugos=1.e-4
141	REAL, DIMENSION(3) :: coeffs
142	LOGICAL :: mixte
143	REAL :: z_0m
144	REAL :: z_0h
145	REAL, DIMENSION(knon) :: cdmm
146	REAL, DIMENSION(knon) :: cdhh
147
148	!------------------RAJOUT POUR ECUME -------------------
149
150	REAL, DIMENSION(knon) :: PQSAT
151	REAL, DIMENSION(knon) :: PSFTH
152	REAL, DIMENSION(knon) :: PFSTQ
153	REAL, DIMENSION(knon) :: PUSTAR
154	REAL, DIMENSION(knon) :: PCD ! Drag coefficient for momentum
155	REAL, DIMENSION(knon) :: PCDN ! Drag coefficient for momentum
156	REAL, DIMENSION(knon) :: PCH ! Drag coefficient for momentum
157	REAL, DIMENSION(knon) :: PCE ! Drag coefficient for momentum
158	REAL, DIMENSION(knon) :: PRI
159	REAL, DIMENSION(knon) :: PRESA
160	REAL, DIMENSION(knon) :: PSSS
161
162	LOGICAL :: OPRECIP
163	LOGICAL :: OPWEBB
164	LOGICAL :: OPERTFLUX
165	LOGICAL :: LPRECIP
166	LOGICAL :: LPWG
167	real, dimension(1) :: z0m_1d, z_0h_1d, sqrt_zdu2_1d, zgeop1_rg_1d ! Pour COARE CNRM
168	! convert scalar to 1D for call
169
170
171
172	LOGICAL, SAVE :: firstcall = .TRUE.
173	!$OMP THREADPRIVATE(firstcall)
174	INTEGER, SAVE :: iflag_corr_sta
175	!$OMP THREADPRIVATE(iflag_corr_sta)
176	INTEGER, SAVE :: iflag_corr_insta
177	!$OMP THREADPRIVATE(iflag_corr_insta)
178	LOGICAL, SAVE :: ok_cdrag_iter
179	!$OMP THREADPRIVATE(ok_cdrag_iter)
180
181	!===================================================================c
182	! Valeurs numeriques des constantes
183	!===================================================================c
184
185
186	! Minimum du carre du vent
187
188	CEPDU2 = (0.1)**2
189
190	! Louis 1982
191
192	CB=5.0
193	CC=5.0
194	CD=5.0
195
196
197	! King 2001
198
199	C2=0.25
200	C3=0.0625
201
202
203	! Louis 1979
204
205	BPRIME=4.7
206	B=9.4
207
208
209	!MO
210
211	ALPHA=5.0
212
213	! Consistent with atke scheme
214	cn=(1./sqrt(cepsilon))**(2./3.)
215	ri0=2./rpi(cinf - cn)ric/cn
216	ri1=-2./rpi * (pr_asym - pr_neut)/pr_slope
217
218
219	! ================================================================= c
220	! Tests avant de commencer
221	! Fuxing WANG, 04/03/2015
222	! To check if there are negative q1, qsurf values.
223	!====================================================================c
224	ng_q1 = 0 ! Initialization
225	ng_qsurf = 0 ! Initialization
226	DO i = 1, knon
227	IF (q1(i).LT.0.0) ng_q1 = ng_q1 + 1
228	IF (qsurf(i).LT.0.0) ng_qsurf = ng_qsurf + 1
229	ENDDO
230	IF (ng_q1.GT.0 .and. prt_level > 5) THEN
231	WRITE(lunout,)" ** Warning: Negative q1(humidity at 1st level) values in cdrag.F90 !"
232	WRITE(lunout,*)" The total number of the grids is: ", ng_q1
233	WRITE(lunout,*)" The negative q1 is set to zero "
234	! abort_message="voir ci-dessus"
235	! CALL abort_physic(modname,abort_message,1)
236	ENDIF
237	IF (ng_qsurf.GT.0 .and. prt_level > 5) THEN
238	WRITE(lunout,)" ** Warning: Negative qsurf(humidity at surface) values in cdrag.F90 !"
239	WRITE(lunout,*)" The total number of the grids is: ", ng_qsurf
240	WRITE(lunout,*)" The negative qsurf is set to zero "
241	! abort_message="voir ci-dessus"
242	! CALL abort_physic(modname,abort_message,1)
243	ENDIF
244
245
246
247	!=============================================================================c
248	! Calcul du cdrag
249	!=============================================================================c
250
251	! On choisit les fonctions de stabilite utilisees au premier appel
252	!**************************************************************************
253	IF (firstcall) THEN
254	iflag_corr_sta=2
255	iflag_corr_insta=2
256	ok_cdrag_iter = .FALSE.
257
258	CALL getin_p('iflag_corr_sta',iflag_corr_sta)
259	CALL getin_p('iflag_corr_insta',iflag_corr_insta)
260	CALL getin_p('ok_cdrag_iter',ok_cdrag_iter)
261
262	firstcall = .FALSE.
263	ENDIF
264
265	!------------------ Rajout (OT2018) --------------------
266	!--------- Rajout pour itération sur rugosité ----------------
267	rugos_itm(:,2) = z0m
268	rugos_itm(:,1) = 3.tol_it_rugosz0m
269
270	rugos_ith(:,2) = z0h !cp nouveau rugos_it
271	rugos_ith(:,1) = 3.tol_it_rugosz0h
272	!--------------------------------------------------------------------
273
274	!xxxxxxxxxxxxxxxxxxxxxxx
275	DO i = 1, knon ! Boucle sur l'horizontal
276	!xxxxxxxxxxxxxxxxxxxxxxx
277
278
279	! calculs preliminaires:
280	!***********************
281
282	zdu2 = MAX(CEPDU2, speed(i)**2)
283	pref(i) = EXP(LOG(psol(i)) - zgeop1(i)/(RDt1(i) &
284	(1.+ RETV * max(q1(i),0.0)))) ! negative q1 set to zero
285	ztsolv = tsurf(i) * (1.0+RETV*max(qsurf(i),0.0)) ! negative qsurf set to zero
286	ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
287	(1.+RETVmax(q1(i),0.0)) ! negative q1 set to zero
288
289	!------------------ Rajout (OT2018) --------------------
290	!-------------- ON DUPLIQUE POUR METTRE ITERATION SUR OCEAN ------------------------
291	IF (iri_in.EQ.1) THEN
292	zri(i) = ri_in(i)
293	ENDIF
294
295	IF (nsrf == is_oce) THEN
296
297	!------------------ Pour Core 2 choix Core Pur ou Core Mixte --------------------
298	IF ((choix_bulk > 1 .AND. choix_bulk < 4) .AND. (nsrf .eq. is_oce)) THEN
299	IF(choix_bulk .eq. 2) THEN
300	mixte = .false.
301	ELSE
302	mixte = .true.
303	ENDIF
304	call clc_core_cp ( sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),t1(i),q1(i),&
305	zgeop1(i)/RG, zgeop1(i)/RG, zgeop1(i)/RG,&
306	psol(i),nit_bulk,mixte,&
307	coeffs,z_0m,z_0h)
308	cdmm(i) = coeffs(1)
309	cdhh(i) = coeffs(2)
310	cdm(i)=cdmm(i)
311	cdh(i)=cdhh(i)
312	write(,) "clc_core cd ch",cdmm(i),cdhh(i)
313
314	!------------------ Pour ECUME --------------------
315	ELSE IF ((choix_bulk .eq. 4) .and. (nsrf .eq. is_oce)) THEN
316	OPRECIP = .false.
317	OPWEBB = .false.
318	OPERTFLUX = .false.
319	IF (nsrf .eq. is_oce) THEN
320	PSSS = 0.0
321	ENDIF
322	call ini_csts
323	call ecumev6_flux( z_0m,t1(i),tsurf(i),&
324	q1(i),qsurf(i),sqrt(zdu2),zgeop1(i)/RG,PSSS,zgeop1(i)/RG,&
325	psol(i),pat1(i), OPRECIP, OPWEBB,&
326	PSFTH,PFSTQ,PUSTAR,PCD,PCDN,&
327	PCH,PCE,PRI,PRESA,prain,&
328	z_0h,OPERTFLUX,coeffs)
329
330	cdmm(i) = coeffs(1)
331	cdhh(i) = coeffs(2)
332	cdm(i)=cdmm(i)
333	cdh(i)=cdhh(i)
334
335	write(,) "ecume cd ch",cdmm(i),cdhh(i)
336
337	!------------------ Pour COARE CNRM --------------------
338	ELSE IF ((choix_bulk .eq. 5) .and. (nsrf .eq. is_oce)) THEN
339	LPRECIP = .false.
340	LPWG = .false.
341	call ini_csts
342
343	z0m_1d = z0m
344	z_0h_1d = z0h
345	sqrt_zdu2_1d = sqrt(zdu2)
346	zgeop1_rg_1d=zgeop1(i)/RG
347	call coare30_flux_cnrm(z0m_1d,t1(i),tsurf(i), q1(i), &
348	sqrt_zdu2_1d,zgeop1_rg_1d,zgeop1_rg_1d,psol(i),qsurf(i),PQSAT, &
349	PSFTH,PFSTQ,PUSTAR,PCD,PCDN,PCH,PCE,PRI, &
350	PRESA,prain,pat1(i),z_0h_1d, LPRECIP, LPWG, coeffs)
351
352	cdmm(i) = coeffs(1)
353	cdhh(i) = coeffs(2)
354	cdm(i)=cdmm(i)
355	cdh(i)=cdhh(i)
356	write(,) "coare CNRM cd ch",cdmm(i),cdhh(i)
357
358	!------------------ Pour COARE Maison --------------------
359	ELSE IF ((choix_bulk .eq. 1) .and. (nsrf .eq. is_oce)) THEN
360	IF ( pblh(i) .eq. 0. ) THEN
361	pblh(i) = 1500.
362	ENDIF
363	write(,) "debug size",size(coeffs)
364	call coare_cp(sqrt(zdu2),t1(i)-tsurf(i),q1(i)-qsurf(i),&
365	t1(i),q1(i),&
366	zgeop1(i)/RG,zgeop1(i)/RG,zgeop1(i)/RG,&
367	psol(i), pblh(i),&
368	nit_bulk,&
369	coeffs,z_0m,z_0h)
370	cdmm(i) = coeffs(1)
371	cdhh(i) = coeffs(3)
372	cdm(i)=cdmm(i)
373	cdh(i)=cdhh(i)
374	write(,) "coare cd ch",cdmm(i),cdhh(i)
375	ELSE
376	!------------------ Pour La param LMDZ (ocean) --------------------
377	zri(i) = zgeop1(i)(ztvd-ztsolv)/(zdu2ztvd)
378	IF (iri_in.EQ.1) THEN
379	zri(i) = ri_in(i)
380	ENDIF
381	ENDIF
382
383
384	!----------------------- Rajout des itérations --------------
385	DO k=1,nit_bulk
386
387	! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
388	!********************************************************************
389	zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*rugos_itm(i,2)))
390	cdmn(i) = zzzcd*zzzcd
391	cdhn(i) = zzzcd(CKAP/LOG(1.+zgeop1(i)/(RGrugos_ith(i,2))))
392
393	! Calcul des fonctions de stabilite FMs, FHs, FMi, FHi :
394	!*******************************************************
395	IF (zri(i) .LT. 0.) THEN
396	SELECT CASE (iflag_corr_insta)
397	CASE (1) ! Louis 1979 + Mascart 1995
398	MU=LOG(MAX(z0m(i)/z0h(i),0.01))
399	CMstar=6.8741+2.6933MU-0.3601(MU*2)+0.0154(MU**3)
400	PM=0.5233-0.0815MU+0.0135(MU*2)-0.001(MU**3)
401	CHstar=3.2165+4.3431MU+0.536(MU*2)-0.0781(MU**3)
402	PH=0.5802-0.1571MU+0.0327(MU*2)-0.0026(MU**3)
403	CH=CHstarBCKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
404	& * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i))) &
405	& * ((zgeop1(i)/(RGz0h(i)))*PH)
406	CM=CMstarBCKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
407	& CKAP/LOG(z0m(i)+zgeop1(i)/(RGz0m(i))) &
408	& * ((zgeop1(i)/(RGz0m(i)))*PM)
409	FM(i)=1.-Bzri(i)/(1.+CMSQRT(ABS(zri(i))))
410	FH(i)=1.-Bzri(i)/(1.+CHSQRT(ABS(zri(i))))
411	CASE (2) ! Louis 1982
412	zucf = 1./(1.+3.0CBCCcdmn(i)SQRT(ABS(zri(i)) &
413	(1.0+zgeop1(i)/(RGz0m(i)))))
414	FM(i) = AMAX1((1.-2.0CBzri(i)*zucf),f_ri_cd_min)
415	FH(i) = AMAX1((1.-3.0CBzri(i)*zucf),f_ri_cd_min)
416	CASE (3) ! Laurent Li
417	FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
418	FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
419	CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
420	sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
421	prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
422	FM(i) = MAX((sm(i)*(3./2.) sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
423	FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
424	CASE default ! Louis 1982
425	zucf = 1./(1.+3.0CBCCcdmn(i)SQRT(ABS(zri(i)) &
426	(1.0+zgeop1(i)/(RGz0m(i)))))
427	FM(i) = AMAX1((1.-2.0CBzri(i)*zucf),f_ri_cd_min)
428	FH(i) = AMAX1((1.-3.0CBzri(i)*zucf),f_ri_cd_min)
429	END SELECT
430	! Calcul des drags
431	cdmm(i)=cdmn(i)*FM(i)
432	cdhh(i)=f_cdrag_tercdhn(i)FH(i)
433	! Traitement particulier des cas oceaniques
434	! on applique Miller et al 1992 en l'absence de gustiness
435	IF (nsrf == is_oce) THEN
436	! cdh(i)=f_cdrag_ocecdhn(i)FH(i)
437	IF (iflag_gusts==0) THEN
438	zcr = (0.0016/(cdmn(i)SQRT(zdu2)))ABS(ztvd-ztsolv)**(1./3.)
439	cdhh(i) =f_cdrag_oce* cdhn(i)(1.0+zcr1.25)*(1./1.25)
440	ENDIF
441	cdmm(i)=MIN(cdmm(i),cdmmax)
442	cdhh(i)=MIN(cdhh(i),cdhmax)
443	! write(,) "LMDZ cd ch",cdmm(i),cdhh(i)
444	END IF
445	ELSE
446
447	!'''''''''''''''
448	! Cas stables :
449	!'''''''''''''''
450	zri(i) = MIN(20.,zri(i))
451	SELECT CASE (iflag_corr_sta)
452	CASE (1) ! Louis 1979 + Mascart 1995
453	FM(i)=MAX(1./((1+BPRIMEzri(i))*2),f_ri_cd_min)
454	FH(i)=FM(i)
455	CASE (2) ! Louis 1982
456	zscf = SQRT(1.+CD*ABS(zri(i)))
457	FM(i)= AMAX1(1. / (1.+2.CBzri(i)/zscf), f_ri_cd_min)
458	FH(i)= AMAX1(1./ (1.+3.CBzri(i)*zscf), f_ri_cd_min )
459	CASE (3) ! Laurent Li
460	FM(i)=MAX(1.0 / (1.0+10.0zri(i)(1+8.0*zri(i))),f_ri_cd_min)
461	FH(i)=FM(i)
462	CASE (4) ! King 2001
463	IF (zri(i) .LT. C2/2.) THEN
464	FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
465	FH(i)= FM(i)
466	ELSE
467	FM(i)=MAX(C3((C2/zri(i))*2),f_ri_cd_min)
468	FH(i)= FM(i)
469	ENDIF
470	CASE (5) ! MO
471	if (zri(i) .LT. 1./alpha) then
472	FM(i)=MAX((1.-alphazri(i))*2,f_ri_cd_min)
473	FH(i)=FM(i)
474	else
475	FM(i)=MAX(1E-7,f_ri_cd_min)
476	FH(i)=FM(i)
477	endif
478	CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
479	sm(i) = MAX(smmin,cn*(1.-zri(i)/ric))
480	! prandlt expression from venayagamoorthy and stretch 2010, Li et al 2019
481	prandtl(i) = pr_neutexp(-pr_slope/pr_neutzri(i)+zri(i)/pr_neut) &
482	+ zri(i) * pr_slope
483	FM(i) = MAX((sm(i)*(3./2.) sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
484	FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
485	CASE default ! Louis 1982
486	zscf = SQRT(1.+CD*ABS(zri(i)))
487	FM(i)= AMAX1(1. / (1.+2.CBzri(i)/zscf), f_ri_cd_min)
488	FH(i)= AMAX1(1./ (1.+3.CBzri(i)*zscf), f_ri_cd_min )
489	END SELECT
490
491	! Calcul des drags
492
493	cdmm(i)=cdmn(i)*FM(i)
494	cdhh(i)=f_cdrag_tercdhn(i)FH(i)
495
496	IF (choix_bulk == 0) THEN
497	cdm(i)=cdmn(i)*FM(i)
498	cdh(i)=f_cdrag_tercdhn(i)FH(i)
499	ENDIF
500
501	IF (nsrf.EQ.is_oce) THEN
502	cdhh(i)=f_cdrag_ocecdhn(i)FH(i)
503	cdmm(i)=MIN(cdmm(i),cdmmax)
504	cdhh(i)=MIN(cdhh(i),cdhmax)
505	ENDIF
506	IF (ok_cdrag_iter) THEN
507	rugos_itm(i,1) = rugos_itm(i,2)
508	rugos_ith(i,1) = rugos_ith(i,2)
509	rugos_itm(i,2) = 0.018cdmm(i) (speed(i))/RG &
510	+ 0.1114e-6 / SQRT(cdmm(i) zdu2)
511
512	!---------- Version SEPARATION DES Z0 ----------------------
513	IF (iflag_z0_oce==0) THEN
514	rugos_ith(i,2) = rugos_itm(i,2)
515	ELSE IF (iflag_z0_oce==1) THEN
516	rugos_ith(i,2) = 0.4014e-6 / SQRT(cdmm(i) zdu2)
517	ENDIF
518	ENDIF
519	ENDIF
520	IF (ok_cdrag_iter) THEN
521	rugos_itm(i,2) = MAX(1.5e-05,rugos_itm(i,2))
522	rugos_ith(i,2) = MAX(1.5e-05,rugos_ith(i,2))
523	ENDIF
524	ENDDO
525	IF (nsrf.EQ.is_oce) THEN
526	cdm(i)=MIN(cdmm(i),cdmmax)
527	cdh(i)=MIN(cdhh(i),cdhmax)
528	ENDIF
529	z0m(i) = rugos_itm(i,2)
530	z0h(i) = rugos_ith(i,2)
531	ELSE ! (nsrf == is_oce)
532	zri(i) = zgeop1(i)(ztvd-ztsolv)/(zdu2ztvd)
533	IF (iri_in.EQ.1) THEN
534	zri(i) = ri_in(i)
535	ENDIF
536
537	! Coefficients CD neutres : k^2/ln(z/z0) et k^2/(ln(z/z0)*ln(z/z0h)):
538	!********************************************************************
539	zzzcd=CKAP/LOG(1.+zgeop1(i)/(RG*z0m(i)))
540	cdmn(i) = zzzcd*zzzcd
541	cdhn(i) = zzzcd(CKAP/LOG(1.+zgeop1(i)/(RGz0h(i))))
542
543
544	! Calcul des fonctions de stabilit?? FMs, FHs, FMi, FHi :
545	!*******************************************************
546	!''''''''''''''
547	! Cas instables
548	!''''''''''''''
549	IF (zri(i) .LT. 0.) THEN
550	SELECT CASE (iflag_corr_insta)
551	CASE (1) ! Louis 1979 + Mascart 1995
552	MU=LOG(MAX(z0m(i)/z0h(i),0.01))
553	CMstar=6.8741+2.6933MU-0.3601(MU*2)+0.0154(MU**3)
554	PM=0.5233-0.0815MU+0.0135(MU*2)-0.001(MU**3)
555	CHstar=3.2165+4.3431MU+0.536(MU*2)-0.0781(MU**3)
556	PH=0.5802-0.1571MU+0.0327(MU*2)-0.0026(MU**3)
557	CH=CHstarBCKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
558	& * CKAPT/LOG(z0h(i)+zgeop1(i)/(RG*z0h(i))) &
559	& * ((zgeop1(i)/(RGz0h(i)))*PH)
560	CM=CMstarBCKAP/LOG(z0m(i)+zgeop1(i)/(RG*z0m(i))) &
561	& CKAP/LOG(z0m(i)+zgeop1(i)/(RGz0m(i))) &
562	& * ((zgeop1(i)/(RGz0m(i)))*PM)
563	FM(i)=1.-Bzri(i)/(1.+CMSQRT(ABS(zri(i))))
564	FH(i)=1.-Bzri(i)/(1.+CHSQRT(ABS(zri(i))))
565	CASE (2) ! Louis 1982
566	zucf = 1./(1.+3.0CBCCcdmn(i)SQRT(ABS(zri(i)) &
567	(1.0+zgeop1(i)/(RGz0m(i)))))
568	FM(i) = AMAX1((1.-2.0CBzri(i)*zucf),f_ri_cd_min)
569	FH(i) = AMAX1((1.-3.0CBzri(i)*zucf),f_ri_cd_min)
570	CASE (3) ! Laurent Li
571	FM(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
572	FH(i) = MAX(SQRT(1.0-18.0*zri(i)),f_ri_cd_min)
573	CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
574	sm(i) = 2./rpi * (cinf - cn) * atan(-zri(i)/ri0) + cn
575	prandtl(i) = -2./rpi * (pr_asym - pr_neut) * atan(zri(i)/ri1) + pr_neut
576	FM(i) = MAX((sm(i)*(3./2.) sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
577	FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
578	CASE default ! Louis 1982
579	zucf = 1./(1.+3.0CBCCcdmn(i)SQRT(ABS(zri(i)) &
580	(1.0+zgeop1(i)/(RGz0m(i)))))
581	FM(i) = AMAX1((1.-2.0CBzri(i)*zucf),f_ri_cd_min)
582	FH(i) = AMAX1((1.-3.0CBzri(i)*zucf),f_ri_cd_min)
583	END SELECT
584	! Calcul des drags
585	cdm(i)=cdmn(i)*FM(i)
586	cdh(i)=f_cdrag_tercdhn(i)FH(i)
587	ELSE
588	!'''''''''''''''
589	! Cas stables :
590	!'''''''''''''''
591	zri(i) = MIN(20.,zri(i))
592	SELECT CASE (iflag_corr_sta)
593	CASE (1) ! Louis 1979 + Mascart 1995
594	FM(i)=MAX(1./((1+BPRIMEzri(i))*2),f_ri_cd_min)
595	FH(i)=FM(i)
596	CASE (2) ! Louis 1982
597	zscf = SQRT(1.+CD*ABS(zri(i)))
598	FM(i)= AMAX1(1. / (1.+2.CBzri(i)/zscf), f_ri_cd_min)
599	FH(i)= AMAX1(1./ (1.+3.CBzri(i)*zscf), f_ri_cd_min )
600	CASE (3) ! Laurent Li
601	FM(i)=MAX(1.0 / (1.0+10.0zri(i)(1+8.0*zri(i))),f_ri_cd_min)
602	FH(i)=FM(i)
603	CASE (4) ! King 2001
604	if (zri(i) .LT. C2/2.) then
605	FM(i)=MAX((1.-zri(i)/C2)**2,f_ri_cd_min)
606	FH(i)= FM(i)
607	else
608	FM(i)=MAX(C3((C2/zri(i))*2),f_ri_cd_min)
609	FH(i)= FM(i)
610	endif
611	CASE (5) ! MO
612	if (zri(i) .LT. 1./alpha) then
613	FM(i)=MAX((1.-alphazri(i))*2,f_ri_cd_min)
614	FH(i)=FM(i)
615	else
616	FM(i)=MAX(1E-7,f_ri_cd_min)
617	FH(i)=FM(i)
618	endif
619	CASE (6) ! Consistent with turbulence scheme (in stationary case) derived in atke (2023)
620	sm(i) = MAX(0.,cn*(1.-zri(i)/ric))
621	prandtl(i) = pr_neut + zri(i) * pr_slope
622	FM(i) = MAX((sm(i)*(3./2.) sqrt(cepsilon) * (1 - zri(i) / prandtl(i))**(1./2.)),f_ri_cd_min)
623	FH(i) = MAX((FM(i) / prandtl(i)), f_ri_cd_min)
624	CASE default ! Louis 1982
625	zscf = SQRT(1.+CD*ABS(zri(i)))
626	FM(i)= AMAX1(1. / (1.+2.CBzri(i)/zscf), f_ri_cd_min)
627	FH(i)= AMAX1(1./ (1.+3.CBzri(i)*zscf), f_ri_cd_min )
628	END SELECT
629	! Calcul des drags
630	cdm(i)=cdmn(i)*FM(i)
631	cdh(i)=f_cdrag_tercdhn(i)FH(i)
632	ENDIF
633	ENDIF ! fin du if (nsrf == is_oce)
634	END DO ! Fin de la boucle sur l'horizontal
635
636	END SUBROUTINE cdrag
637
638	END MODULE cdrag_mod

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

Download in other formats:

Original Format