source: LMDZ4/branches/LMDZ4_V2_patch/libf/phylmd/ajsec.F @ 5023

Last change on this file since 5023 was 665, checked in by (none), 19 years ago

This commit was manufactured by cvs2svn to create branch
'LMDZ4_V2_patch'.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.5 KB
RevLine 
[524]1!
2! $Header$
3!
4      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
5      IMPLICIT none
6c======================================================================
7c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
8c Objet: ajustement sec (adaptation du GCM du LMD)
9c======================================================================
10c Arguments:
11c t-------input-R- Temperature
12c
13c d_t-----output-R-Incrementation de la temperature
14c======================================================================
15#include "dimensions.h"
16#include "dimphy.h"
17#include "YOMCST.h"
18      REAL paprs(klon,klev+1), pplay(klon,klev)
19      REAL t(klon,klev), q(klon,klev)
20      REAL d_t(klon,klev), d_q(klon,klev)
21c
22      INTEGER limbas, limhau ! les couches a ajuster
23ccc      PARAMETER (limbas=klev-3, limhau=klev)
24      PARAMETER (limbas=1, limhau=klev)
25c
26      LOGICAL mixq
27ccc      PARAMETER (mixq=.TRUE.)
28      PARAMETER (mixq=.FALSE.)
29c
30      REAL zh(klon,klev)
31      REAL zq(klon,klev)
32      REAL zpk(klon,klev)
33      REAL zpkdp(klon,klev)
34      REAL hm, sm, qm
35      LOGICAL modif(klon), down
36      INTEGER i, k, k1, k2
37c
38c Initialisation:
39c
40      DO k = 1, klev
41      DO i = 1, klon
42         d_t(i,k) = 0.0
43         d_q(i,k) = 0.0
44      ENDDO
45      ENDDO
46c------------------------------------- detection des profils a modifier
47      DO k = limbas, limhau
48      DO i = 1, klon
49         zpk(i,k) = pplay(i,k)**RKAPPA
50         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
51         zq(i,k) = q(i,k)
52      ENDDO
53      ENDDO
54c
55      DO k = limbas, limhau
56      DO i = 1, klon
57         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
58      ENDDO
59      ENDDO
60c
61      DO i = 1, klon
62         modif(i) = .FALSE.
63      ENDDO
64      DO k = limbas+1, limhau
65      DO i = 1, klon
66      IF (.NOT.modif(i)) THEN
67         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
68      ENDIF
69      ENDDO
70      ENDDO
71c------------------------------------- correction des profils instables
72      DO 1080 i = 1, klon
73      IF (modif(i)) THEN
74          k2 = limbas
75 8000     CONTINUE
76            k2 = k2 + 1
77            IF (k2 .GT. limhau) goto 8001
78            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
79              k1 = k2 - 1
80              k = k1
81              sm = zpkdp(i,k2)
82              hm = zh(i,k2)
83              qm = zq(i,k2)
84 8020         CONTINUE
85                sm = sm +zpkdp(i,k)
86                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
87                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
88                down = .FALSE.
89                IF (k1 .ne. limbas) THEN
90                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
91                ENDIF
92                IF (down) THEN
93                  k1 = k1 - 1
94                  k = k1
95                ELSE
96                  IF ((k2 .EQ. limhau)) GOTO 8021
97                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
98                  k2 = k2 + 1
99                  k = k2
100                ENDIF
101              GOTO 8020
102 8021         CONTINUE
103c------------ nouveau profil : constant (valeur moyenne)
104              DO k = k1, k2
105                zh(i,k) = hm
106                zq(i,k) = qm
107              ENDDO
108              k2 = k2 + 1
109            ENDIF
110          GOTO 8000
111 8001     CONTINUE
112      ENDIF
113 1080 CONTINUE
114c
115      DO k = limbas, limhau
116      DO i = 1, klon
117         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
118         d_q(i,k) = zq(i,k) - q(i,k)
119      ENDDO
120      ENDDO
121c
122      IF (limbas.GT.1) THEN
123      DO k = 1, limbas-1
124      DO i = 1, klon
125         d_t(i,k) = 0.0
126         d_q(i,k) = 0.0
127      ENDDO
128      ENDDO
129      ENDIF
130c
131      IF (limhau.LT.klev) THEN
132      DO k = limhau+1, klev
133      DO i = 1, klon
134         d_t(i,k) = 0.0
135         d_q(i,k) = 0.0
136      ENDDO
137      ENDDO
138      ENDIF
139c
140      IF (.NOT.mixq) THEN
141      DO k = 1, klev
142      DO i = 1, klon
143         d_q(i,k) = 0.0
144      ENDDO
145      ENDDO
146      ENDIF
147c
148      RETURN
149      END
150      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
151      IMPLICIT none
152c======================================================================
153c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
154c Objet: ajustement sec (adaptation du GCM du LMD)
155c======================================================================
156c Arguments:
157c t-------input-R- Temperature
158c
159c d_t-----output-R-Incrementation de la temperature
160c======================================================================
161#include "dimensions.h"
162#include "dimphy.h"
163#include "YOMCST.h"
164      REAL paprs(klon,klev+1), pplay(klon,klev)
165      REAL t(klon,klev)
166      REAL d_t(klon,klev)
167c
168      REAL local_h(klon,klev)
169      REAL hm, sm
170      LOGICAL modif(klon), down
171      INTEGER i, l, l1, l2
172c------------------------------------- detection des profils a modifier
173      DO i = 1, klon
174         modif(i)   = .false.
175      ENDDO
176c
177      DO l = 1, klev
178      DO i = 1, klon
179         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
180      ENDDO
181      ENDDO
182c
183      DO l = 2, klev
184      DO i = 1, klon
185         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
186            modif(i) = .true.
187         ELSE
188            modif(i) = modif(i)
189         ENDIF
190      ENDDO
191      ENDDO
192c------------------------------------- correction des profils instables
193      do 1080 i = 1, klon
194        if (modif(i)) then
195          l2 = 1
196 8000     continue
197            l2 = l2 + 1
198            if (l2 .gt. klev) goto 8001
199            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
200              l1 = l2 - 1
201              l  = l1
202              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
203              hm = local_h(i, l2)
204 8020         continue
205                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
206                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
207     .                         * (local_h(i, l) - hm) / sm
208                down = .false.
209                if (l1 .ne. 1) then
210                  if (hm .lt. local_h(i, l1-1)) then
211                    down = .true.
212                  end if
213                end if
214                if (down) then
215                  l1 = l1 - 1
216                  l  = l1
217                else
218                  if ((l2 .eq. klev)) GOTO 8021
219                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
220                  l2 = l2 + 1
221                  l  = l2
222                end if
223              go to 8020
224 8021         continue
225c------------ nouveau profil : constant (valeur moyenne)
226              do 1100 l = l1, l2
227                local_h(i, l) = hm
228 1100         continue
229              l2 = l2 + 1
230            end if
231          go to 8000
232 8001     continue
233        end if
234 1080 continue
235c
236      DO l = 1, klev
237      DO i = 1, klon
238         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
239      ENDDO
240      ENDDO
241c
242      RETURN
243      END
Note: See TracBrowser for help on using the repository browser.