source: LMDZ5/trunk/libf/phylmd/calwake.F90 @ 2079

Last change on this file since 2079 was 1992, checked in by lguez, 11 years ago

Converted to free source form files in libf/phylmd which were still in
fixed source form. The conversion was done using the polish mode of
the NAG Fortran Compiler.

In addition to converting to free source form, the processing of the
files also:

-- indented the code (including comments);

-- set Fortran keywords to uppercase, and set all other identifiers
to lower case;

-- added qualifiers to end statements (for example "end subroutine
conflx", instead of "end");

-- changed the terminating statements of all DO loops so that each
loop ends with an ENDDO statement (instead of a labeled continue).

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