source: LMDZ4/branches/LMDZ4-dev-20091210/libf/phylmd/calwake.F @ 4104

Last change on this file since 4104 was 990, checked in by Laurent Fairhead, 16 years ago

Correction probleme de dimension sur une variable passee a un sous-programme
JYG
LF
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.1 KB
Line 
1      SUBROUTINE CALWAKE(paprs,pplay,dtime
2     :             ,t,q,omgb
3     :             ,dt_dwn,dq_dwn,M_dwn,M_up
4     :             ,dt_a,dq_a,sigd
5     :             ,wdt_PBL,wdq_PBL
6     :             ,udt_PBL,udq_PBL
7     o             ,wake_deltat,wake_deltaq,wake_dth
8     o             ,wake_h,wake_s,wake_dens
9     o             ,wake_pe,wake_fip,wake_gfl
10     o             ,dt_wake,dq_wake
11     o             ,wake_k
12     o             ,undi_t,undi_q
13     o             ,wake_omgbdth,wake_dp_omgb
14     o             ,wake_dtKE,wake_dqKE
15     o             ,wake_dtPBL,wake_dqPBL
16     o             ,wake_omg,wake_dp_deltomg
17     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
18     o             ,wake_ddeltat,wake_ddeltaq)
19***************************************************************
20*                                                             *
21* CALWAKE                                                     *
22*           interface avec le schema de calcul de la poche    *
23*           froide                                            *
24*                                                             *
25* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
26* modified by :  ROEHRIG Romain,    01/30/2007                *
27***************************************************************
28*
29      USE dimphy
30      IMPLICIT none
31c======================================================================
32#include "dimensions.h"
33!#include "dimphy.h"
34#include "YOMCST.h"
35
36c Arguments
37c----------
38
39      INTEGER  i,l,ktopw(klon)
40      REAL   dtime
41
42      REAL paprs(klon,klev+1),pplay(klon,klev)
43      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
44      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
45      REAL M_up(klon,klev)
46      REAL dt_a(klon,klev), dq_a(klon,klev)
47      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
48      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
49      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
50      REAL dt_wake(klon,klev),dq_wake(klon,klev)
51      REAL wake_d_deltat_gw(klon,klev)
52      REAL wake_h(klon),wake_s(klon)
53      REAL wake_dth(klon,klev)
54      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
55      REAL undi_t(klon,klev),undi_q(klon,klev)
56      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
57      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
58      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
59      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
60      REAL wake_spread(klon,klev),wake_Cstar(klon)
61      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
62      REAL d_deltatw(klon,klev), d_deltaqw(klon,klev)
63      INTEGER wake_k(klon)
64      REAL sigd(klon)
65      REAL wake_dens(klon)
66
67C  Variable internes
68C  -----------------
69
70      REAL aire
71      REAL p(klon,klev),ph(klon,klev+1),pi(klon,klev)
72      REAL te(klon,klev),qe(klon,klev),omgbe(klon,klev+1)
73      REAL dtdwn(klon,klev),dqdwn(klon,klev)
74      REAL dta(klon,klev),dqa(klon,klev)
75      REAL wdtPBL(klon,klev),wdqPBL(klon,klev)
76      REAL udtPBL(klon,klev),udqPBL(klon,klev)
77      REAL amdwn(klon,klev),amup(klon,klev)
78      REAL dtw(klon,klev),dqw(klon,klev),dth(klon,klev)
79      REAL d_deltat_gw(klon,klev)
80      REAL dtls(klon,klev),dqls(klon,klev)
81      REAL tu(klon,klev),qu(klon,klev)
82      REAL hw(klon),sigmaw(klon),wape(klon),fip(klon),gfl(klon)
83      REAL omgbdth(klon,klev),dp_omgb(klon,klev)
84      REAL dtKE(klon,klev),dqKE(klon,klev)
85      REAL dtPBL(klon,klev),dqPBL(klon,klev)
86      REAL omg(klon,klev+1),dp_deltomg(klon,klev),spread(klon,klev)
87      REAL Cstar(klon)
88      REAL sigd0(klon),wdens(klon)
89
90      REAL RDCP
91
92c      print *, '-> calwake, wake_s ', wake_s(1)
93
94      RDCP=1./3.5
95
96
97c-----------------------------------------------------------
98cIM 290108     DO 999 i=1,klon   ! a vectoriser
99c----------------------------------------------------------
100
101
102      DO l=1,klev
103      DO i=1,klon
104        p(i,l)= pplay(i,l)
105        ph(i,l)= paprs(i,l)
106        pi(i,l) = (pplay(i,l)/100000.)**RDCP
107
108        te(i,l) = t(i,l)
109        qe(i,l) = q(i,l)
110        omgbe(i,l) = omgb(i,l)
111
112        dtdwn(i,l)= dt_dwn(i,l)
113        dqdwn(i,l)= dq_dwn(i,l)
114        dta(i,l)= dt_a(i,l)
115        dqa(i,l)= dq_a(i,l)
116        wdtPBL(i,l)= wdt_PBL(i,l)
117        wdqPBL(i,l)= wdq_PBL(i,l)
118        udtPBL(i,l)= udt_PBL(i,l)
119        udqPBL(i,l)= udq_PBL(i,l)
120      ENDDO
121      ENDDO
122
123      omgbe(:,klev+1) = 0.
124     
125      DO i=1,klon
126      sigd0(i)=sigd(i)
127      ENDDO
128c      print*, 'sigd0,sigd', sigd0, sigd(i)
129      DO i=1,klon
130      ph(i,klev+1)=0.
131      ENDDO
132
133      DO i=1,klon
134      ktopw(i) = wake_k(i)
135      ENDDO
136
137      DO l=1,klev
138      DO i=1,klon
139        dtw(i,l) = wake_deltat(i,l)
140        dqw(i,l) = wake_deltaq(i,l)
141      ENDDO
142      ENDDO
143
144      DO l=1,klev
145      DO i=1,klon
146        dtls(i,l)=dt_wake(i,l)
147        dqls(i,l)=dq_wake(i,l)
148      ENDDO
149      ENDDO
150
151      DO i=1,klon
152      hw(i) = wake_h(i)
153      sigmaw(i)= wake_s(i)
154      ENDDO
155
156cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
157cfkc  on veut le flux de masse au milieu des couches
158
159      DO l=1,klev-1
160      DO i=1,klon
161        amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
162        amdwn(i,l)= (M_dwn(i,l+1))
163      ENDDO
164      ENDDO
165
166c au sommet le flux de masse est nul
167
168      DO i=1,klon
169      amdwn(i,klev)=0.5*M_dwn(i,klev)
170      ENDDO
171c
172      DO l = 1,klev
173      DO i=1,klon
174        amup(i,l)=M_up(i,l)
175      ENDDO
176      ENDDO
177
178      call WAKE(p,ph,pi,dtime,sigd0
179     $                ,te,qe,omgbe
180     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
181     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
182     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
183     $                ,dtls,dqls,ktopw
184     $                ,omgbdth,dp_omgb,wdens
185     $                ,tu,qu
186     $                ,dtKE,dqKE
187     $                ,dtPBL,dqPBL
188     $                ,omg,dp_deltomg,spread
189     $                ,Cstar,d_deltat_gw
190     $                ,d_deltatw,d_deltaqw)
191
192      DO i=1,klon
193       IF (ktopw(i) .GT. 0) THEN
194         DO l=1,klev
195           wake_deltat(i,l)= dtw(i,l)
196           wake_deltaq(i,l)= dqw(i,l)
197           wake_d_deltat_gw(i,l)= d_deltat_gw(i,l)
198           wake_omgbdth(i,l) = omgbdth(i,l)
199           wake_dp_omgb(i,l) = dp_omgb(i,l)
200           wake_dtKE(i,l) = dtKE(i,l)
201           wake_dqKE(i,l) = dqKE(i,l)
202           wake_dtPBL(i,l) = dtPBL(i,l)
203           wake_dqPBL(i,l) = dqPBL(i,l)
204           wake_omg(i,l) = omg(i,l)
205           wake_dp_deltomg(i,l) = dp_deltomg(i,l)
206           wake_spread(i,l) = spread(i,l)
207           wake_dth(i,l) = dth(i,l)
208           dt_wake(i,l) = dtls(i,l)
209           dq_wake(i,l) = dqls(i,l)
210           undi_t(i,l) = tu(i,l)
211           undi_q(i,l) = qu(i,l)
212           wake_ddeltat(i,l) = d_deltatw(i,l)
213           wake_ddeltaq(i,l) = d_deltaqw(i,l)
214         ENDDO
215       ELSE
216         DO l = 1,klev
217           wake_deltat(i,l)= 0.
218           wake_deltaq(i,l)= 0.
219           wake_d_deltat_gw(i,l)= 0.
220           wake_omgbdth(i,l) = 0.
221           wake_dp_omgb(i,l) = 0.
222           wake_dtKE(i,l) = 0.
223           wake_dqKE(i,l) = 0.
224           wake_omg(i,l) = 0.
225           wake_dp_deltomg(i,l) = 0.
226           wake_spread(i,l) = 0.
227           wake_dth(i,l)=0.
228           dt_wake(i,l)=0.
229           dq_wake(i,l)=0.
230           undi_t(i,l)=te(i,l)
231           undi_q(i,l)=qe(i,l)
232         ENDDO
233       ENDIF
234
235       wake_h(i)= hw(i)
236       wake_s(i)= sigmaw(i)
237       wake_pe(i)= wape(i)
238       wake_fip(i)= fip(i)
239       wake_gfl(i) = gfl(i)
240       wake_k(i) =ktopw(i)
241       wake_Cstar(i) = Cstar(i)
242       wake_dens(i) = wdens(i)
243c
244cIM 290108 999  CONTINUE
245c
246      ENDDO
247      RETURN
248      END
249      SUBROUTINE CALWAKE_scal(paprs,pplay,dtime
250     :             ,t,q,omgb
251     :             ,dt_dwn,dq_dwn,M_dwn,M_up
252     :             ,dt_a,dq_a,sigd
253     :             ,wdt_PBL,wdq_PBL
254     :             ,udt_PBL,udq_PBL
255     o             ,wake_deltat,wake_deltaq,wake_dth
256     o             ,wake_h,wake_s,wake_dens
257     o             ,wake_pe,wake_fip,wake_gfl
258     o             ,dt_wake,dq_wake
259     o             ,wake_k
260     o             ,undi_t,undi_q
261     o             ,wake_omgbdth,wake_dp_omgb
262     o             ,wake_dtKE,wake_dqKE
263     o             ,wake_dtPBL,wake_dqPBL
264     o             ,wake_omg,wake_dp_deltomg
265     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
266     o             ,wake_ddeltat,wake_ddeltaq)
267***************************************************************
268*                                                             *
269* CALWAKE                                                     *
270*           interface avec le schema de calcul de la poche    *
271*           froide                                            *
272*                                                             *
273* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
274* modified by :  ROEHRIG Romain,    01/30/2007                *
275***************************************************************
276*
277      USE dimphy
278      IMPLICIT none
279c======================================================================
280
281#include "dimensions.h"
282cccc#include "dimphy.h"
283#include "YOMCST.h"
284
285c Arguments
286c----------
287
288      INTEGER  i,l,ktopw
289      REAL   dtime
290
291      REAL paprs(klon,klev+1),pplay(klon,klev)
292      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
293      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
294      REAL M_up(klon,klev)
295      REAL dt_a(klon,klev), dq_a(klon,klev)
296      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
297      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
298      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
299      REAL dt_wake(klon,klev),dq_wake(klon,klev)
300      REAL wake_d_deltat_gw(klon,klev)
301      REAL wake_h(klon),wake_s(klon)
302      REAL wake_dth(klon,klev)
303      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
304      REAL undi_t(klon,klev),undi_q(klon,klev)
305      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
306      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
307      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
308      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
309      REAL wake_spread(klon,klev),wake_Cstar(klon)
310      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
311      REAL d_deltatw(klev), d_deltaqw(klev)
312      INTEGER wake_k(klon)
313      REAL sigd(klon)
314      REAL wake_dens(klon)
315
316C  Variable internes
317C  -----------------
318
319      REAL aire
320      REAL p(klev),ph(klev+1),pi(klev)
321      REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev)
322      REAL dta(klev),dqa(klev)
323      REAL wdtPBL(klev),wdqPBL(klev)
324      REAL udtPBL(klev),udqPBL(klev)
325      REAL amdwn(klev),amup(klev)
326      REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev)
327      REAL dtls(klev),dqls(klev)
328      REAL tu(klev),qu(klev)
329      REAL hw,sigmaw,wape,fip,gfl
330      REAL omgbdth(klev),dp_omgb(klev)
331      REAL dtKE(klev),dqKE(klev)
332      REAL dtPBL(klev),dqPBL(klev)
333      REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar
334      REAL sigd0,wdens
335
336      REAL RDCP
337
338c      print *, '-> calwake, wake_s ', wake_s(1)
339
340      RDCP=1./3.5
341
342c-----------------------------------------------------------
343      DO 999 i=1,klon   ! a vectoriser
344c----------------------------------------------------------
345
346
347      DO l=1,klev
348        p(l)= pplay(i,l)
349        ph(l)= paprs(i,l)
350        pi(l) = (pplay(i,l)/100000.)**RDCP
351
352        te(l) = t(i,l)
353        qe(l) = q(i,l)
354        omgbe(l) = omgb(i,l)
355
356        dtdwn(l)= dt_dwn(i,l)
357        dqdwn(l)= dq_dwn(i,l)
358        dta(l)= dt_a(i,l)
359        dqa(l)= dq_a(i,l)
360        wdtPBL(l)= wdt_PBL(i,l)
361        wdqPBL(l)= wdq_PBL(i,l)
362        udtPBL(l)= udt_PBL(i,l)
363        udqPBL(l)= udq_PBL(i,l)
364      ENDDO
365     
366      sigd0=sigd(i)
367c      print*, 'sigd0,sigd', sigd0, sigd(i)
368      ph(klev+1)=0.
369
370      ktopw = wake_k(i)
371
372      DO l=1,klev
373        dtw(l) = wake_deltat(i,l)
374        dqw(l) = wake_deltaq(i,l)
375      ENDDO
376
377      DO l=1,klev
378        dtls(l)=dt_wake(i,l)
379        dqls(l)=dq_wake(i,l)
380      ENDDO
381
382      hw = wake_h(i)
383      sigmaw = wake_s(i)
384
385cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
386cfkc  on veut le flux de masse au milieu des couches
387
388      DO l=1,klev-1
389        amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
390        amdwn(l)= (M_dwn(i,l+1))
391      ENDDO
392
393c au sommet le flux de masse est nul
394
395      amdwn(klev)=0.5*M_dwn(i,klev)
396c
397      DO l = 1,klev
398        amup(l)=M_up(i,l)
399      ENDDO
400
401      call WAKE_scal(p,ph,pi,dtime,sigd0
402     $                ,te,qe,omgbe
403     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
404     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
405     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
406     $                ,dtls,dqls,ktopw
407     $                ,omgbdth,dp_omgb,wdens
408     $                ,tu,qu
409     $                ,dtKE,dqKE
410     $                ,dtPBL,dqPBL
411     $                ,omg,dp_deltomg,spread
412     $                ,Cstar,d_deltat_gw
413     $                ,d_deltatw,d_deltaqw)
414
415       IF (ktopw .GT. 0) THEN
416         DO l=1,klev
417           wake_deltat(i,l)= dtw(l)
418           wake_deltaq(i,l)= dqw(l)
419           wake_d_deltat_gw(i,l)= d_deltat_gw(l)
420           wake_omgbdth(i,l) = omgbdth(l)
421           wake_dp_omgb(i,l) = dp_omgb(l)
422           wake_dtKE(i,l) = dtKE(l)
423           wake_dqKE(i,l) = dqKE(l)
424           wake_dtPBL(i,l) = dtPBL(l)
425           wake_dqPBL(i,l) = dqPBL(l)
426           wake_omg(i,l) = omg(l)
427           wake_dp_deltomg(i,l) = dp_deltomg(l)
428           wake_spread(i,l) = spread(l)
429           wake_dth(i,l) = dth(l)
430           dt_wake(i,l) = dtls(l)
431           dq_wake(i,l) = dqls(l)
432           undi_t(i,l) = tu(l)
433           undi_q(i,l) = qu(l)
434           wake_ddeltat(i,l) = d_deltatw(l)
435           wake_ddeltaq(i,l) = d_deltaqw(l)
436         ENDDO
437       ELSE
438         DO l = 1,klev
439           wake_deltat(i,l)= 0.
440           wake_deltaq(i,l)= 0.
441           wake_d_deltat_gw(i,l)= 0.
442           wake_omgbdth(i,l) = 0.
443           wake_dp_omgb(i,l) = 0.
444           wake_dtKE(i,l) = 0.
445           wake_dqKE(i,l) = 0.
446           wake_omg(i,l) = 0.
447           wake_dp_deltomg(i,l) = 0.
448           wake_spread(i,l) = 0.
449           wake_dth(i,l)=0.
450           dt_wake(i,l)=0.
451           dq_wake(i,l)=0.
452           undi_t(i,l)=te(l)
453           undi_q(i,l)=qe(l)
454         ENDDO
455       ENDIF
456
457       wake_h(i)= hw
458       wake_s(i)= sigmaw
459       wake_pe(i)= wape
460       wake_fip(i)= fip
461       wake_gfl(i) = gfl
462       wake_k(i) =ktopw
463       wake_Cstar(i) = Cstar
464       wake_dens(i) = wdens
465c
466 999  CONTINUE
467c
468      RETURN
469      END
Note: See TracBrowser for help on using the repository browser.