Context Navigation

cv3_estatmix.F90 @ 3871

Last change on this file since 3871 was 3043, checked in by Ehouarn Millour, 7 years ago
Some fixes to enable compiling with the pgf compiler and updated arch files for pgf on Ciclad. EM
File size: 6.1 KB

Line
1	SUBROUTINE cv3_estatmix(len, nd, iflag, plim1, plim2, p, ph, &
2	t, q, u, v, h, gz, w, &
3	wi, nk, tmix, thmix, qmix, qsmix, umix, vmix, plcl)
4	! **************************************************************
5	! *
6	! CV3_ESTATMIX Determine the properties of an adiabatic updraft *
7	! made of air coming from several layers by *
8	! mixing static energy *
9	! *
10	! written by : Grandpeix Jean-Yves, 28/12/2001, 13.14.24 *
11	! modified by : Filiberti M-A 06/2005 vectorisation *
12	! ****************************************************************
13
14	IMPLICIT NONE
15	! ==============================================================
16
17	! estatmix : determines theta, t, q, qs, u and v of the lifted mixture
18	! made of air between plim1 and plim2 with weighting w.
19	! If plim1 and plim2 fall within the same model layer, then theta, ... v
20	! are those of that layer.
21	! A minimum value (dpmin) is imposed upon plim1-plim2
22
23	! ===============================================================
24
25	include "cvthermo.h"
26	include "YOETHF.h"
27	include "YOMCST.h"
28	include "FCTTRE.h"
29	!inputs:
30	INTEGER, INTENT (IN) :: nd, len
31	INTEGER, DIMENSION (len), INTENT (IN) :: nk
32	REAL, DIMENSION (len), INTENT (IN) :: plim1, plim2
33	REAL, DIMENSION (len,nd), INTENT (IN) :: t, q
34	REAL, DIMENSION (len,nd), INTENT (IN) :: u, v
35	REAL, DIMENSION (len,nd), INTENT (IN) :: h ! static energy of the layers
36	REAL, DIMENSION (len,nd), INTENT (IN) :: gz
37	REAL, DIMENSION (nd), INTENT (IN) :: w
38	REAL, DIMENSION (len,nd), INTENT (IN) :: p
39	REAL, DIMENSION (len,nd+1), INTENT (IN) :: ph
40	!input/output:
41	INTEGER, DIMENSION (len), INTENT (INOUT) :: iflag
42	!outputs:
43	REAL, DIMENSION (len), INTENT (OUT) :: tmix, thmix, qmix
44	REAL, DIMENSION (len), INTENT (OUT) :: umix, vmix
45	REAL, DIMENSION (len), INTENT (OUT) :: qsmix
46	REAL, DIMENSION (len), INTENT (OUT) :: plcl
47	REAL, DIMENSION (len,nd), INTENT (OUT) :: wi
48	!internal variables :
49	INTEGER i, j
50	INTEGER niflag7
51	INTEGER, DIMENSION(len) :: j1, j2
52	REAL :: a, b
53	REAL :: cpn
54	REAL :: x, y, p0, zdelta, zcor
55	REAL, SAVE :: dpmin=1.
56	!$OMP THREADPRIVATE(dpmin)
57	REAL, DIMENSION(len) :: plim2p ! = min(plim2(:),plim1(:)-dpmin)
58	REAL, DIMENSION(len) :: dpw, coef
59	REAL, DIMENSION(len) :: hmix ! static energy of the updraft
60	REAL, DIMENSION(len) :: rdcp, pnk
61	REAL, DIMENSION(len) :: rh, chi
62	REAL, DIMENSION(len) :: eqwght
63	REAL, DIMENSION(len,nd) :: p1, p2
64
65
66	!! print *,' ->cv3_vertmix, plim1,plim2 ', plim1,plim2 !jyg
67	plim2p(:) = min(plim2(:),plim1(:)-dpmin)
68	j1(:)=nd
69	j2(:) = 0
70	DO j = 1, nd
71	DO i = 1, len
72	IF (plim1(i)<=ph(i,j)) j1(i) = j
73	!!! IF (plim2p(i)>=ph(i,j+1) .AND. plim2p(i)<ph(i,j)) j2(i) = j
74	IF (plim2p(i)< ph(i,j)) j2(i) = j
75	END DO
76	END DO
77
78	DO j = 1, nd
79	DO i = 1, len
80	wi(i, j) = 0.
81	END DO
82	END DO
83	DO i = 1, len
84	hmix(i) = 0.
85	qmix(i) = 0.
86	umix(i) = 0.
87	vmix(i) = 0.
88	dpw(i) = 0.
89	pnk(i) = p(i, nk(i))
90	END DO
91	eqwght(:) = 0.
92
93	p0 = 1000.
94
95	DO i = 1, len
96	IF (j2(i) < j1(i)) THEN
97	coef(i) = 1.
98	eqwght(i) = 1.
99	ELSE
100	coef(i) = 1./(plim1(i)-plim2p(i))
101	ENDIF
102	END DO
103
104	!! print *,'cv3_vertmix, j1,j2,coef ', j1,j2,coef !jyg
105
106	DO j = 1, nd
107	DO i = 1, len
108	IF (j>=j1(i) .AND. j<=j2(i)) THEN
109	p1(i, j) = min(ph(i,j), plim1(i))
110	p2(i, j) = max(ph(i,j+1), plim2p(i))
111	! CRtest:couplage thermiques: deja normalise
112	! wi(i,j) = w(j)
113	! print*,'wi',wi(i,j)
114	wi(i, j) = w(j)(p1(i,j)-p2(i,j))coef(i)+eqwght(i)
115	dpw(i) = dpw(i) + wi(i, j)
116
117	!! print *,'cv3_vertmix, j, wi(1,j),dpw ', j, wi(1,j),dpw !jyg
118
119	END IF
120	END DO
121	END DO
122
123	! CR:print
124	! do i=1,len
125	! print*,'plim',plim1(i),plim2p(i)
126	! enddo
127	DO j = 1, nd
128	DO i = 1, len
129	IF (j>=j1(i) .AND. j<=j2(i)) THEN
130	wi(i, j) = wi(i, j)/dpw(i)
131	hmix(i) = hmix(i) + h(i, j)*wi(i, j)
132	qmix(i) = qmix(i) + q(i, j)*wi(i, j)
133	umix(i) = umix(i) + u(i, j)*wi(i, j)
134	vmix(i) = vmix(i) + v(i, j)*wi(i, j)
135	END IF
136	END DO
137	END DO
138
139	DO i = 1, len
140	rdcp(i) = (rrd(1.-qmix(i))+qmix(i)rrv)/(cpd(1.-qmix(i))+qmix(i)cpv)
141	END DO
142
143
144	!! print *,'cv3_vertmix, rdcp ', rdcp !jyg
145
146	DO i = 1, len
147	tmix(i) = (hmix(i) - gz(i,1))/(cpd(1.-qmix(i)) + qmix(i)cpv)
148	! (Use of Cpv since we are dealing with dry static energy)
149	thmix(i) = tmix(i)(p0/pnk(i))*rdcp(i)
150	! print*,'tmix thmix hmix ',tmix(i),thmix(i),hmix(i)
151	zdelta = max(0., sign(1.,rtt-tmix(i)))
152	qsmix(i) = r2esfoeew(tmix(i), zdelta)/(pnk(i)100.)
153	qsmix(i) = min(0.5, qsmix(i))
154	zcor = 1./(1.-retv*qsmix(i))
155	qsmix(i) = qsmix(i)*zcor
156	END DO
157
158	! -------------------------------------------------------------------
159	! --- Calculate lifted condensation level of air at parcel origin level
160	! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
161	! -------------------------------------------------------------------
162
163	a = 1669.0 ! convect3
164	b = 122.0 ! convect3
165
166
167	niflag7 = 0
168	DO i = 1, len
169
170	IF (iflag(i)/=7) THEN ! modif sb Jun7th 2002
171
172	rh(i) = qmix(i)/qsmix(i)
173	chi(i) = tmix(i)/(a-b*rh(i)-tmix(i)) ! convect3
174	! ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
175	! MASQUE UN PB POTENTIEL
176	chi(i) = max(chi(i), 0.)
177	rh(i) = max(rh(i), 0.)
178	plcl(i) = pnk(i)(rh(i)*chi(i))
179	IF (((plcl(i)<200.0) .OR. (plcl(i)>=2000.0)) .AND. (iflag(i)==0)) &
180	iflag(i) = 8
181
182	ELSE
183
184	niflag7 = niflag7 + 1
185	plcl(i) = plim2p(i)
186
187	END IF ! iflag=7
188
189	! print*,'NIFLAG7 =',niflag7
190
191	END DO
192
193	!! print *,' cv3_vertmix->' !jyg
194
195
196	RETURN
197	END SUBROUTINE cv3_estatmix
198

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

Download in other formats:

Original Format