source: LMDZ5/branches/LMDZ5_AR5/libf/dyn3d/integrd.F @ 3110

Last change on this file since 3110 was 1550, checked in by lguez, 13 years ago

Bug fix in "bilan_dyn_p". The index was out of bounds in the removed
assignment . Also, the removed assignment was useless.

Bug fix in "coefkzmin". The size of a dummy array cannot exceed the
size of the associated actual array. ("coefkzmin" is called by
"coef_diff_turb".) "km(:, klev+1)" and "kn(:, klev+1)" were not
defined in "coefkzmin" so this was maybe an innocuous bug.

  • 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 1550 2011-07-05 09:44:55Z fairhead $
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         print *, ' dans integrd'
92         stop 1
93        ENDIF
94      ENDDO
95c
96      DO  ij    = 1, iim
97       tppn(ij) = aire(   ij   ) * ps(  ij    )
98       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
99      ENDDO
100       tpn      = SSUM(iim,tppn,1)/apoln
101       tps      = SSUM(iim,tpps,1)/apols
102      DO ij   = 1, iip1
103       ps(   ij   )  = tpn
104       ps(ij+ip1jm)  = tps
105      ENDDO
106c
107c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
108c
109      CALL pression ( ip1jmp1, ap, bp, ps, p )
110      CALL massdair (     p  , masse         )
111
112      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
113      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
114c
115
116c    ............   integration  de  ucov, vcov,  h     ..............
117
118      DO l = 1,llm
119
120       DO ij = iip2,ip1jm
121        uscr( ij )   =  ucov( ij,l )
122        ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
123       ENDDO
124
125       DO ij = 1,ip1jm
126        vscr( ij )   =  vcov( ij,l )
127        vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
128       ENDDO
129
130       DO ij = 1,ip1jmp1
131        hscr( ij )    =  teta(ij,l)
132        teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
133     &                + dt * dteta(ij,l) / masse(ij,l)
134       ENDDO
135
136c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
137c
138c
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
150c
151
152       IF(leapf)  THEN
153         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
154         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
155         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
156       END IF
157
158      ENDDO ! of DO l = 1,llm
159
160
161c
162c   .......  integration de   q   ......
163c
164c$$$      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
165c$$$c
166c$$$       IF( forward. OR . leapf )  THEN
167c$$$        DO iq = 1,2
168c$$$        DO  l = 1,llm
169c$$$        DO ij = 1,ip1jmp1
170c$$$        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
171c$$$     $                            finvmasse(ij,l)
172c$$$        ENDDO
173c$$$        ENDDO
174c$$$        ENDDO
175c$$$       ELSE
176c$$$         DO iq = 1,2
177c$$$         DO  l = 1,llm
178c$$$         DO ij = 1,ip1jmp1
179c$$$         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
180c$$$         ENDDO
181c$$$         ENDDO
182c$$$         ENDDO
183c$$$
184c$$$       END IF
185c$$$c
186c$$$      ENDIF
187
188      if (planet_type.eq."earth") then
189! Earth-specific treatment of first 2 tracers (water)
190        DO l = 1, llm
191          DO ij = 1, ip1jmp1
192            deltap(ij,l) =  p(ij,l) - p(ij,l+1)
193          ENDDO
194        ENDDO
195
196        CALL qminimum( q, nq, deltap )
197
198c
199c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
200c
201
202       DO iq = 1, nq
203        DO l = 1, llm
204
205           DO ij = 1, iim
206             qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
207             qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
208           ENDDO
209             qpn  =  SSUM(iim,qppn,1)/apoln
210             qps  =  SSUM(iim,qpps,1)/apols
211
212           DO ij = 1, iip1
213             q(   ij   ,l,iq)  = qpn
214             q(ij+ip1jm,l,iq)  = qps
215           ENDDO
216
217        ENDDO
218       ENDDO
219
220
221      CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
222
223      endif ! of if (planet_type.eq."earth")
224c
225c
226c     .....   FIN  de l'integration  de   q    .......
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.