source: trunk/LMDZ.VENUS/libf/phyvenus/ajsec.rcpd @ 777

Last change on this file since 777 was 3, checked in by slebonnois, 14 years ago

Creation de repertoires:

  • chantiers : pour communiquer sur nos projets de modifs
  • documentation : pour stocker les docs

Ajout de:

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