source: LMDZ5/branches/LMDZ5-dev032011/libf/dyn3d/integrd.F @ 2448

Last change on this file since 2448 was 1454, checked in by Laurent Fairhead, 14 years ago

Merge of LMDZ5V1.0-dev branch r1453 into LMDZ5 trunk r1434


Fusion entre la version r1453 de la branche de développement LMDZ5V1.0-dev
et le tronc LMDZ5 (r1434)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.8 KB
Line 
1!
2! $Id: integrd.F 1454 2010-11-18 12:01:24Z jyg $
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      use control_mod, only : planet_type
9
10      IMPLICIT NONE
11
12
13c=======================================================================
14c
15c   Auteur:  P. Le Van
16c   -------
17c
18c   objet:
19c   ------
20c
21c   Incrementation des tendances dynamiques
22c
23c=======================================================================
24c-----------------------------------------------------------------------
25c   Declarations:
26c   -------------
27
28#include "dimensions.h"
29#include "paramet.h"
30#include "comconst.h"
31#include "comgeom.h"
32#include "comvert.h"
33#include "logic.h"
34#include "temps.h"
35#include "serre.h"
36
37c   Arguments:
38c   ----------
39
40      INTEGER nq
41
42      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
43      REAL q(ip1jmp1,llm,nq)
44      REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
45
46      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
47      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
48
49      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
50      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
51      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
52
53c   Local:
54c   ------
55
56      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
57      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
58      REAL p(ip1jmp1,llmp1)
59      REAL tpn,tps,tppn(iim),tpps(iim)
60      REAL qpn,qps,qppn(iim),qpps(iim)
61      REAL deltap( ip1jmp1,llm )
62
63      INTEGER  l,ij,iq
64
65      REAL SSUM
66
67c-----------------------------------------------------------------------
68
69      DO  l = 1,llm
70        DO  ij = 1,iip1
71         ucov(    ij    , l) = 0.
72         ucov( ij +ip1jm, l) = 0.
73         uscr(     ij      ) = 0.
74         uscr( ij +ip1jm   ) = 0.
75        ENDDO
76      ENDDO
77
78
79c    ............    integration  de       ps         ..............
80
81      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
82
83      DO ij = 1,ip1jmp1
84       pscr (ij)    = ps(ij)
85       ps (ij)      = psm1(ij) + dt * dp(ij)
86      ENDDO
87c
88      DO ij = 1,ip1jmp1
89        IF( ps(ij).LT.0. ) THEN
90         PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
91         STOP' dans integrd'
92        ENDIF
93      ENDDO
94c
95      DO  ij    = 1, iim
96       tppn(ij) = aire(   ij   ) * ps(  ij    )
97       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
98      ENDDO
99       tpn      = SSUM(iim,tppn,1)/apoln
100       tps      = SSUM(iim,tpps,1)/apols
101      DO ij   = 1, iip1
102       ps(   ij   )  = tpn
103       ps(ij+ip1jm)  = tps
104      ENDDO
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 l = 1,llm
118
119       DO ij = iip2,ip1jm
120        uscr( ij )   =  ucov( ij,l )
121        ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
122       ENDDO
123
124       DO ij = 1,ip1jm
125        vscr( ij )   =  vcov( ij,l )
126        vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
127       ENDDO
128
129       DO 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       ENDDO
134
135c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
136c
137c
138       DO  ij   = 1, iim
139        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
140        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
141       ENDDO
142        tpn      = SSUM(iim,tppn,1)/apoln
143        tps      = SSUM(iim,tpps,1)/apols
144
145       DO ij   = 1, iip1
146        teta(   ij   ,l)  = tpn
147        teta(ij+ip1jm,l)  = tps
148       ENDDO
149c
150
151       IF(leapf)  THEN
152         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
153         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
154         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
155       END IF
156
157      ENDDO ! of DO l = 1,llm
158
159
160c
161c   .......  integration de   q   ......
162c
163c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
164c$$$c
165c$$$       IF( forward. OR . leapf )  THEN
166c$$$        DO iq = 1,2
167c$$$        DO  l = 1,llm
168c$$$        DO ij = 1,ip1jmp1
169c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
170c$$$     $                            finvmasse(ij,l)
171c$$$        ENDDO
172c$$$        ENDDO
173c$$$        ENDDO
174c$$$       ELSE
175c$$$         DO iq = 1,2
176c$$$         DO  l = 1,llm
177c$$$         DO ij = 1,ip1jmp1
178c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
179c$$$         ENDDO
180c$$$         ENDDO
181c$$$         ENDDO
182c$$$
183c$$$       END IF
184c$$$c
185c$$$      ENDIF
186
187      if (planet_type.eq."earth") then
188! Earth-specific treatment of first 2 tracers (water)
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 )
196
197c
198c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
199c
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
220      CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
221
222      endif ! of if (planet_type.eq."earth")
223c
224c
225c     .....   FIN  de l'integration  de   q    .......
226
227c    .................................................................
228
229
230      IF( leapf )  THEN
231         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
232         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
233      END IF
234
235      RETURN
236      END
Note: See TracBrowser for help on using the repository browser.