/[lmdze]/trunk/libf/phylmd/Orography/gwprofil.f90
ViewVC logotype

Contents of /trunk/libf/phylmd/Orography/gwprofil.f90

Parent Directory Parent Directory | Revision Log Revision Log


Revision 23 - (show annotations)
Mon Dec 14 15:25:16 2009 UTC (14 years, 6 months ago) by guez
File size: 6742 byte(s)
Split "orografi.f": one file for each procedure. Put the created files
in new directory "Orography".

Removed argument "vcov" of procedure "sortvarc". Removed arguments
"itau" and "time" of procedure "caldyn0". Removed arguments "itau",
"time" and "vcov" of procedure "sortvarc0".

Removed argument "time" of procedure "dynredem1". Removed NetCDF
variable "temps" in files "start.nc" and "restart.nc", because its
value is always 0.

Removed argument "nq" of procedures "iniadvtrac" and "leapfrog". The
number of "tracers read in "traceur.def" must now be equal to "nqmx",
or "nqmx" must equal 4 if there is no file "traceur.def". Replaced
variable "nq" by constant "nqmx" in "leapfrog".

NetCDF variable for ozone field in "coefoz.nc" must now be called
"tro3" instead of "r".

Fixed bug in "zenang".

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 yomcst
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

  ViewVC Help
Powered by ViewVC 1.1.21