source: LMDZ4/trunk/libf/phy_IPCC_AR4/ajsec.F @ 868

Last change on this file since 868 was 868, checked in by Laurent Fairhead, 17 years ago

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