source: LMDZ4/branches/IPSL-CM4_IPCC_patches/libf/dyn3d/integrd.F @ 5373

Last change on this file since 5373 was 524, checked in by lmdzadmin, 21 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.7 KB
Line 
1!
2! $Header$
3!
4      SUBROUTINE integrd
5     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
6     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
7
8      IMPLICIT NONE
9
10
11c=======================================================================
12c
13c   Auteur:  P. Le Van
14c   -------
15c
16c   objet:
17c   ------
18c
19c   Incrementation des tendances dynamiques
20c
21c=======================================================================
22c-----------------------------------------------------------------------
23c   Declarations:
24c   -------------
25
26#include "dimensions.h"
27#include "paramet.h"
28#include "comconst.h"
29#include "comgeom.h"
30#include "comvert.h"
31#include "logic.h"
32#include "temps.h"
33#include "serre.h"
34#include "advtrac.h"
35
36c   Arguments:
37c   ----------
38
39      INTEGER nq
40
41      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
42      REAL q(ip1jmp1,llm,nq)
43      REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
44
45      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
46      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
47
48      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
49      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
50      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
51
52c   Local:
53c   ------
54
55      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
56      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
57      REAL p(ip1jmp1,llmp1)
58      REAL tpn,tps,tppn(iim),tpps(iim)
59      REAL qpn,qps,qppn(iim),qpps(iim)
60      REAL deltap( ip1jmp1,llm )
61
62      INTEGER  l,ij,iq
63
64      REAL SSUM
65
66c-----------------------------------------------------------------------
67
68      DO  l = 1,llm
69        DO  ij = 1,iip1
70         ucov(    ij    , l) = 0.
71         ucov( ij +ip1jm, l) = 0.
72         uscr(     ij      ) = 0.
73         uscr( ij +ip1jm   ) = 0.
74        ENDDO
75      ENDDO
76
77
78c    ............    integration  de       ps         ..............
79
80      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
81
82      DO 2 ij = 1,ip1jmp1
83       pscr (ij)    = ps(ij)
84       ps (ij)      = psm1(ij) + dt * dp(ij)
85   2  CONTINUE
86c
87      DO ij = 1,ip1jmp1
88        IF( ps(ij).LT.0. ) THEN
89         PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
90         STOP' dans integrd'
91        ENDIF
92      ENDDO
93c
94      DO  ij    = 1, iim
95       tppn(ij) = aire(   ij   ) * ps(  ij    )
96       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
97      ENDDO
98       tpn      = SSUM(iim,tppn,1)/apoln
99       tps      = SSUM(iim,tpps,1)/apols
100      DO ij   = 1, iip1
101       ps(   ij   )  = tpn
102       ps(ij+ip1jm)  = tps
103      ENDDO
104c
105c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
106c
107      CALL pression ( ip1jmp1, ap, bp, ps, p )
108      CALL massdair (     p  , masse         )
109
110      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
111      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
112c
113
114c    ............   integration  de  ucov, vcov,  h     ..............
115
116      DO 10 l = 1,llm
117
118      DO 4 ij = iip2,ip1jm
119      uscr( ij )   =  ucov( ij,l )
120      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
121   4  CONTINUE
122
123      DO 5 ij = 1,ip1jm
124      vscr( ij )   =  vcov( ij,l )
125      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
126   5  CONTINUE
127
128      DO 6 ij = 1,ip1jmp1
129      hscr( ij )    =  teta(ij,l)
130      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
131     $                + dt * dteta(ij,l) / masse(ij,l)
132   6  CONTINUE
133
134c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
135c
136c
137      DO  ij   = 1, iim
138        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
139        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
140      ENDDO
141        tpn      = SSUM(iim,tppn,1)/apoln
142        tps      = SSUM(iim,tpps,1)/apols
143
144      DO ij   = 1, iip1
145        teta(   ij   ,l)  = tpn
146        teta(ij+ip1jm,l)  = tps
147      ENDDO
148c
149
150      IF(leapf)  THEN
151         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
152         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
153         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
154      END IF
155
156  10  CONTINUE
157
158
159c
160c   .......  integration de   q   ......
161c
162c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
163c$$$c
164c$$$       IF( forward. OR . leapf )  THEN
165c$$$        DO iq = 1,2
166c$$$        DO  l = 1,llm
167c$$$        DO ij = 1,ip1jmp1
168c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
169c$$$     $                            finvmasse(ij,l)
170c$$$        ENDDO
171c$$$        ENDDO
172c$$$        ENDDO
173c$$$       ELSE
174c$$$         DO iq = 1,2
175c$$$         DO  l = 1,llm
176c$$$         DO ij = 1,ip1jmp1
177c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
178c$$$         ENDDO
179c$$$         ENDDO
180c$$$         ENDDO
181c$$$
182c$$$       END IF
183c$$$c
184c$$$      ENDIF
185
186         DO l = 1, llm
187          DO ij = 1, ip1jmp1
188           deltap(ij,l) =  p(ij,l) - p(ij,l+1)
189          ENDDO
190         ENDDO
191
192         CALL qminimum( q, nq, deltap )
193c
194c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
195c
196
197      DO iq = 1, nq
198        DO l = 1, llm
199
200           DO ij = 1, iim
201             qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
202             qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
203           ENDDO
204             qpn  =  SSUM(iim,qppn,1)/apoln
205             qps  =  SSUM(iim,qpps,1)/apols
206
207           DO ij = 1, iip1
208             q(   ij   ,l,iq)  = qpn
209             q(ij+ip1jm,l,iq)  = qps
210           ENDDO
211
212        ENDDO
213      ENDDO
214
215
216         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
217c
218c
219c     .....   FIN  de l'integration  de   q    .......
220
22115    continue
222
223c    .................................................................
224
225
226      IF( leapf )  THEN
227         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
228         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
229      END IF
230
231      RETURN
232      END
Note: See TracBrowser for help on using the repository browser.