source: LMDZ.3.3/branches/LF/libf/dyn3d/integrd.F @ 1972

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