Context Navigation

cdrag_mod.F90 @ 4744

Last change on this file since 4744 was 4725, checked in by Laurent Fairhead, 13 months ago
Bug that prevented numeric convergence with old physics
Property svn:executable set to ``* Property svn:keywords set to `Id`
File size: 25.2 KB

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

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

Download in other formats:

Original Format