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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 38 - (hide annotations)
Thu Jan 6 17:52:19 2011 UTC (13 years, 5 months ago) by guez
File size: 6744 byte(s) 
Extracted ASCII art from "inigeom" into a separate text file in the
documentation.

"test_disvert" now creates a separate file for layer thicknesses.

Moved variables from module "yomcst" to module "suphec_m" because this
is where those variables are defined. Kept in "yomcst" only parameters
of Earth orbit. Gave the attribute "parameter" to some variables of
module "suphec_m".

Variables of module "yoethf" were defined in procedure "suphec". Moved
these definitions to a new procedure "yoethf" in module "yoethf_m".
1 guez 23 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 guez 38 USE suphec_m
53 guez 23 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