1 |
SUBROUTINE gwprofil(nlon,nlev,kgwd,kdx,ktest,kkcrith,kcrit,paphm1,prho, & |
2 |
pstab,pvph,pri,ptau,pdmod,psig,pvar) |
3 |
|
4 |
!**** *GWPROFIL* |
5 |
|
6 |
! PURPOSE. |
7 |
! -------- |
8 |
|
9 |
!** INTERFACE. |
10 |
! ---------- |
11 |
! FROM *GWDRAG* |
12 |
|
13 |
! EXPLICIT ARGUMENTS : |
14 |
! -------------------- |
15 |
! ==== INPUTS === |
16 |
! ==== OUTPUTS === |
17 |
|
18 |
! IMPLICIT ARGUMENTS : NONE |
19 |
! -------------------- |
20 |
|
21 |
! METHOD: |
22 |
! ------- |
23 |
! THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS: |
24 |
! IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND |
25 |
! AND THE TOP OF THE BLOCKED LAYER (KKENVH). |
26 |
! IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE |
27 |
! BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR |
28 |
! NONLINEAR GRAVITY WAVE BREAKING. |
29 |
! ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL |
30 |
! LEVEL (KCRIT) OR WHEN IT BREAKS. |
31 |
|
32 |
|
33 |
|
34 |
! EXTERNALS. |
35 |
! ---------- |
36 |
|
37 |
|
38 |
! REFERENCE. |
39 |
! ---------- |
40 |
|
41 |
! SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S." |
42 |
|
43 |
! AUTHOR. |
44 |
! ------- |
45 |
|
46 |
! MODIFICATIONS. |
47 |
! -------------- |
48 |
! PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93) |
49 |
!----------------------------------------------------------------------- |
50 |
USE dimens_m |
51 |
USE dimphy |
52 |
USE suphec_m |
53 |
USE yoegwd |
54 |
IMPLICIT NONE |
55 |
|
56 |
|
57 |
|
58 |
|
59 |
|
60 |
!----------------------------------------------------------------------- |
61 |
|
62 |
!* 0.1 ARGUMENTS |
63 |
! --------- |
64 |
|
65 |
INTEGER nlon, nlev |
66 |
INTEGER kkcrith(nlon), kcrit(nlon), kdx(nlon), ktest(nlon) |
67 |
|
68 |
|
69 |
REAL paphm1(nlon,nlev+1), pstab(nlon,nlev+1), prho(nlon,nlev+1), & |
70 |
pvph(nlon,nlev+1), pri(nlon,nlev+1), ptau(nlon,nlev+1) |
71 |
|
72 |
REAL pdmod(nlon) |
73 |
REAL, INTENT (IN) :: psig(nlon) |
74 |
REAL, INTENT (IN) :: pvar(nlon) |
75 |
|
76 |
!----------------------------------------------------------------------- |
77 |
|
78 |
!* 0.2 LOCAL ARRAYS |
79 |
! ------------ |
80 |
|
81 |
INTEGER ilevh, ji, kgwd, jl, jk |
82 |
REAL zsqr, zalfa, zriw, zdel, zb, zalpha, zdz2n |
83 |
REAL zdelp, zdelpt |
84 |
REAL zdz2(klon,klev), znorm(klon), zoro(klon) |
85 |
REAL ztau(klon,klev+1) |
86 |
|
87 |
!----------------------------------------------------------------------- |
88 |
|
89 |
!* 1. INITIALIZATION |
90 |
! -------------- |
91 |
|
92 |
! print *,' entree gwprofil' |
93 |
100 CONTINUE |
94 |
|
95 |
|
96 |
!* COMPUTATIONAL CONSTANTS. |
97 |
! ------------- ---------- |
98 |
|
99 |
ilevh = klev/3 |
100 |
|
101 |
! DO 400 ji=1,kgwd |
102 |
! jl=kdx(ji) |
103 |
! Modif vectorisation 02/04/2004 |
104 |
DO 400 jl = 1, klon |
105 |
IF (ktest(jl)==1) THEN |
106 |
zoro(jl) = psig(jl)*pdmod(jl)/4./max(pvar(jl),1.0) |
107 |
ztau(jl,klev+1) = ptau(jl,klev+1) |
108 |
END IF |
109 |
400 CONTINUE |
110 |
|
111 |
|
112 |
DO 430 jk = klev, 2, -1 |
113 |
|
114 |
|
115 |
!* 4.1 CONSTANT WAVE STRESS UNTIL TOP OF THE |
116 |
! BLOCKING LAYER. |
117 |
410 CONTINUE |
118 |
|
119 |
! DO 411 ji=1,kgwd |
120 |
! jl=kdx(ji) |
121 |
! Modif vectorisation 02/04/2004 |
122 |
DO 411 jl = 1, klon |
123 |
IF (ktest(jl)==1) THEN |
124 |
IF (jk>kkcrith(jl)) THEN |
125 |
ptau(jl,jk) = ztau(jl,klev+1) |
126 |
! ENDIF |
127 |
! IF(JK.EQ.KKCRITH(JL)) THEN |
128 |
ELSE |
129 |
ptau(jl,jk) = grahilo*ztau(jl,klev+1) |
130 |
END IF |
131 |
END IF |
132 |
411 CONTINUE |
133 |
|
134 |
!* 4.15 CONSTANT SHEAR STRESS UNTIL THE TOP OF THE |
135 |
! LOW LEVEL FLOW LAYER. |
136 |
415 CONTINUE |
137 |
|
138 |
|
139 |
!* 4.2 WAVE DISPLACEMENT AT NEXT LEVEL. |
140 |
|
141 |
420 CONTINUE |
142 |
|
143 |
! DO 421 ji=1,kgwd |
144 |
! jl=kdx(ji) |
145 |
! Modif vectorisation 02/04/2004 |
146 |
DO 421 jl = 1, klon |
147 |
IF (ktest(jl)==1) THEN |
148 |
IF (jk<kkcrith(jl)) THEN |
149 |
znorm(jl) = gkdrag*prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk)* & |
150 |
zoro(jl) |
151 |
zdz2(jl,jk) = ptau(jl,jk+1)/max(znorm(jl),gssec) |
152 |
END IF |
153 |
END IF |
154 |
421 CONTINUE |
155 |
|
156 |
!* 4.3 WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT |
157 |
!* AND STRESS: BREAKING EVALUATION AND CRITICAL |
158 |
! LEVEL |
159 |
|
160 |
|
161 |
! DO 431 ji=1,kgwd |
162 |
! jl=Kdx(ji) |
163 |
! Modif vectorisation 02/04/2004 |
164 |
DO 431 jl = 1, klon |
165 |
IF (ktest(jl)==1) THEN |
166 |
|
167 |
IF (jk<kkcrith(jl)) THEN |
168 |
IF ((ptau(jl,jk+1)<gtsec) .OR. (jk<=kcrit(jl))) THEN |
169 |
ptau(jl,jk) = 0.0 |
170 |
ELSE |
171 |
zsqr = sqrt(pri(jl,jk)) |
172 |
zalfa = sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk) |
173 |
zriw = pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2 |
174 |
IF (zriw<grcrit) THEN |
175 |
zdel = 4./zsqr/grcrit + 1./grcrit**2 + 4./grcrit |
176 |
zb = 1./grcrit + 2./zsqr |
177 |
zalpha = 0.5*(-zb+sqrt(zdel)) |
178 |
zdz2n = (pvph(jl,jk)*zalpha)**2/pstab(jl,jk) |
179 |
ptau(jl,jk) = znorm(jl)*zdz2n |
180 |
ELSE |
181 |
ptau(jl,jk) = znorm(jl)*zdz2(jl,jk) |
182 |
END IF |
183 |
ptau(jl,jk) = min(ptau(jl,jk),ptau(jl,jk+1)) |
184 |
END IF |
185 |
END IF |
186 |
END IF |
187 |
431 CONTINUE |
188 |
|
189 |
430 CONTINUE |
190 |
440 CONTINUE |
191 |
|
192 |
! REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL |
193 |
|
194 |
! DO 530 ji=1,kgwd |
195 |
! jl=kdx(ji) |
196 |
! Modif vectorisation 02/04/2004 |
197 |
DO 530 jl = 1, klon |
198 |
IF (ktest(jl)==1) THEN |
199 |
ztau(jl,kkcrith(jl)) = ptau(jl,kkcrith(jl)) |
200 |
ztau(jl,nstra) = ptau(jl,nstra) |
201 |
END IF |
202 |
530 CONTINUE |
203 |
|
204 |
DO 531 jk = 1, klev |
205 |
|
206 |
! DO 532 ji=1,kgwd |
207 |
! jl=kdx(ji) |
208 |
! Modif vectorisation 02/04/2004 |
209 |
DO 532 jl = 1, klon |
210 |
IF (ktest(jl)==1) THEN |
211 |
|
212 |
|
213 |
IF (jk>kkcrith(jl)) THEN |
214 |
|
215 |
zdelp = paphm1(jl,jk) - paphm1(jl,klev+1) |
216 |
zdelpt = paphm1(jl,kkcrith(jl)) - paphm1(jl,klev+1) |
217 |
ptau(jl,jk) = ztau(jl,klev+1) + (ztau(jl,kkcrith(jl))-ztau(jl, & |
218 |
klev+1))*zdelp/zdelpt |
219 |
|
220 |
END IF |
221 |
|
222 |
END IF |
223 |
532 CONTINUE |
224 |
|
225 |
! REORGANISATION IN THE STRATOSPHERE |
226 |
|
227 |
! DO 533 ji=1,kgwd |
228 |
! jl=kdx(ji) |
229 |
! Modif vectorisation 02/04/2004 |
230 |
DO 533 jl = 1, klon |
231 |
IF (ktest(jl)==1) THEN |
232 |
|
233 |
|
234 |
IF (jk<nstra) THEN |
235 |
|
236 |
zdelp = paphm1(jl,nstra) |
237 |
zdelpt = paphm1(jl,jk) |
238 |
ptau(jl,jk) = ztau(jl,nstra)*zdelpt/zdelp |
239 |
|
240 |
END IF |
241 |
|
242 |
END IF |
243 |
533 CONTINUE |
244 |
|
245 |
! REORGANISATION IN THE TROPOSPHERE |
246 |
|
247 |
! DO 534 ji=1,kgwd |
248 |
! jl=kdx(ji) |
249 |
! Modif vectorisation 02/04/2004 |
250 |
DO 534 jl = 1, klon |
251 |
IF (ktest(jl)==1) THEN |
252 |
|
253 |
|
254 |
IF (jk<kkcrith(jl) .AND. jk>nstra) THEN |
255 |
|
256 |
zdelp = paphm1(jl,jk) - paphm1(jl,kkcrith(jl)) |
257 |
zdelpt = paphm1(jl,nstra) - paphm1(jl,kkcrith(jl)) |
258 |
ptau(jl,jk) = ztau(jl,kkcrith(jl)) + (ztau(jl,nstra)-ztau(jl, & |
259 |
kkcrith(jl)))*zdelp/zdelpt |
260 |
|
261 |
END IF |
262 |
END IF |
263 |
534 CONTINUE |
264 |
|
265 |
|
266 |
531 CONTINUE |
267 |
|
268 |
|
269 |
RETURN |
270 |
END |