source: LMDZ.3.3/branches/LF/libf/phylmd/ajsec.F @ 369

Last change on this file since 369 was 2, checked in by lmdz, 25 years ago

Initial revision

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