source: LMDZ.3.3/trunk/libf/phylmd/ajsec.F @ 4032

Last change on this file since 4032 was 33, checked in by lmdz, 25 years ago

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