/[lmdze]/trunk/Sources/dyn3d/integrd.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/integrd.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 32 by guez, Tue Apr 6 17:52:58 2010 UTC revision 40 by guez, Tue Feb 22 13:49:36 2011 UTC
# Line 4  module integrd_m Line 4  module integrd_m
4    
5  contains  contains
6    
7    SUBROUTINE integrd(nq,vcovm1,ucovm1,tetam1,psm1,massem1,dv,du,dteta,dp, &    SUBROUTINE integrd(vcovm1, ucovm1, tetam1, psm1, massem1, dv, du, &
8         vcov,ucov,teta,q,ps,masse,finvmaold,leapf, dt)         dteta, dp, vcov, ucov, teta, q, ps, masse, finvmaold, dt, leapf)
9    
10      ! From dyn3d/integrd.F,v 1.1.1.1 2004/05/19 12:53:05      ! From dyn3d/integrd.F, version 1.1.1.1 2004/05/19 12:53:05
11      !   Auteur:  P. Le Van                                                        ! Auteur: P. Le Van
12      !   objet:                                                                    ! Objet: incrémentation des tendances dynamiques
     !   Incrementation des tendances dynamiques                              
13    
     USE dimens_m, ONLY : iim, llm  
     USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1, llmp1  
14      USE comvert, ONLY : ap, bp      USE comvert, ONLY : ap, bp
15      USE comgeom, ONLY : aire, apoln, apols      USE comgeom, ONLY : aire, apoln, apols
16      USE pression_m, ONLY : pression      USE dimens_m, ONLY : iim, jjm, llm
17      USE filtreg_m, ONLY : filtreg      USE filtreg_m, ONLY : filtreg
18        use nr_util, only: assert
19        USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1, llmp1
20    
21      !   Arguments:                                                                ! Arguments:
   
     INTEGER, intent(in):: nq  
   
     REAL vcov(ip1jm,llm), ucov(ip1jmp1,llm), teta(ip1jmp1,llm)  
     REAL q(ip1jmp1,llm,nq)  
     REAL ps(ip1jmp1), masse(ip1jmp1,llm)  
   
     REAL vcovm1(ip1jm,llm), ucovm1(ip1jmp1,llm)  
     REAL tetam1(ip1jmp1,llm), psm1(ip1jmp1), massem1(ip1jmp1,llm)  
22    
23      REAL dv(ip1jm,llm), du(ip1jmp1,llm)      REAL vcov(ip1jm, llm), ucov(ip1jmp1, llm), teta(ip1jmp1, llm)
24      REAL dteta(ip1jmp1,llm), dp(ip1jmp1)      REAL q(:, :, :, :) ! (iim + 1, jjm + 1, llm, nq)
25      REAL finvmaold(ip1jmp1,llm)      REAL ps(ip1jmp1), masse(ip1jmp1, llm)
26    
27        REAL vcovm1(ip1jm, llm), ucovm1(ip1jmp1, llm)
28        REAL tetam1(ip1jmp1, llm), psm1(ip1jmp1), massem1(ip1jmp1, llm)
29    
30        REAL dv(ip1jm, llm), du(ip1jmp1, llm)
31        REAL dteta(ip1jmp1, llm), dp(ip1jmp1)
32        REAL finvmaold(ip1jmp1, llm)
33      LOGICAL, INTENT (IN) :: leapf      LOGICAL, INTENT (IN) :: leapf
34      real, intent(in):: dt      real, intent(in):: dt
35    
36      !   Local:                                                                    ! Local:
37    
38        INTEGER nq
39      REAL vscr(ip1jm), uscr(ip1jmp1), hscr(ip1jmp1), pscr(ip1jmp1)      REAL vscr(ip1jm), uscr(ip1jmp1), hscr(ip1jmp1), pscr(ip1jmp1)
40      REAL massescr(ip1jmp1,llm), finvmasse(ip1jmp1,llm)      REAL massescr(ip1jmp1, llm), finvmasse(ip1jmp1, llm)
41      REAL p(ip1jmp1,llmp1)      REAL p(ip1jmp1, llmp1)
42      REAL tpn, tps, tppn(iim), tpps(iim)      REAL tpn, tps, tppn(iim), tpps(iim)
43      REAL qpn, qps, qppn(iim), qpps(iim)      REAL qpn, qps, qppn(iim), qpps(iim)
44      REAL deltap(ip1jmp1,llm)      REAL deltap(ip1jmp1, llm)
45    
46      INTEGER l, ij, iq      INTEGER l, ij, iq
47    
# Line 51  contains Line 49  contains
49    
50      !-----------------------------------------------------------------------      !-----------------------------------------------------------------------
51    
52        call assert(size(q, 1) == iim + 1, size(q, 2) == jjm + 1, &
53             size(q, 3) == llm, "integrd")
54        nq = size(q, 4)
55    
56      DO l = 1, llm      DO l = 1, llm
57         DO ij = 1, iip1         DO ij = 1, iip1
58            ucov(ij,l) = 0.            ucov(ij, l) = 0.
59            ucov(ij+ip1jm,l) = 0.            ucov(ij+ip1jm, l) = 0.
60            uscr(ij) = 0.            uscr(ij) = 0.
61            uscr(ij+ip1jm) = 0.            uscr(ij+ip1jm) = 0.
62         END DO         END DO
63      END DO      END DO
64    
65        ! integration de ps
66    
67      !    ............    integration  de       ps         ..............          CALL scopy(ip1jmp1*llm, masse, 1, massescr, 1)
   
     CALL scopy(ip1jmp1*llm,masse,1,massescr,1)  
68    
69      DO ij = 1, ip1jmp1      DO ij = 1, ip1jmp1
70         pscr(ij) = ps(ij)         pscr(ij) = ps(ij)
# Line 81  contains Line 82  contains
82         tppn(ij) = aire(ij)*ps(ij)         tppn(ij) = aire(ij)*ps(ij)
83         tpps(ij) = aire(ij+ip1jm)*ps(ij+ip1jm)         tpps(ij) = aire(ij+ip1jm)*ps(ij+ip1jm)
84      END DO      END DO
85      tpn = ssum(iim,tppn,1)/apoln      tpn = ssum(iim, tppn, 1)/apoln
86      tps = ssum(iim,tpps,1)/apols      tps = ssum(iim, tpps, 1)/apols
87      DO ij = 1, iip1      DO ij = 1, iip1
88         ps(ij) = tpn         ps(ij) = tpn
89         ps(ij+ip1jm) = tps         ps(ij+ip1jm) = tps
90      END DO      END DO
91    
92      !  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 .      ! Calcul de la nouvelle masse d'air au dernier temps integre t+1
   
     CALL pression(ip1jmp1,ap,bp,ps,p)  
     CALL massdair(p,masse)  
   
     CALL scopy(ijp1llm,masse,1,finvmasse,1)  
     CALL filtreg(finvmasse,jjp1,llm,-2,2,.TRUE.,1)  
93    
94        forall (l = 1: llm + 1) p(:, l) = ap(l) + bp(l) * ps
95        CALL massdair(p, masse)
96    
97      !    ............   integration  de  ucov, vcov,  h     ..............        CALL scopy(ijp1llm, masse, 1, finvmasse, 1)
98        CALL filtreg(finvmasse, jjp1, llm, -2, 2, .TRUE., 1)
99    
100      DO  l = 1, llm      ! integration de ucov, vcov, h
101    
102        DO l = 1, llm
103         DO ij = iip2, ip1jm         DO ij = iip2, ip1jm
104            uscr(ij) = ucov(ij,l)            uscr(ij) = ucov(ij, l)
105            ucov(ij,l) = ucovm1(ij,l) + dt*du(ij,l)            ucov(ij, l) = ucovm1(ij, l) + dt*du(ij, l)
106         END DO         END DO
107    
108         DO ij = 1, ip1jm         DO ij = 1, ip1jm
109            vscr(ij) = vcov(ij,l)            vscr(ij) = vcov(ij, l)
110            vcov(ij,l) = vcovm1(ij,l) + dt*dv(ij,l)            vcov(ij, l) = vcovm1(ij, l) + dt*dv(ij, l)
111         END DO         END DO
112    
113         DO ij = 1, ip1jmp1         DO ij = 1, ip1jmp1
114            hscr(ij) = teta(ij,l)            hscr(ij) = teta(ij, l)
115            teta(ij,l) = tetam1(ij,l)*massem1(ij,l)/masse(ij,l) + &            teta(ij, l) = tetam1(ij, l)*massem1(ij, l)/masse(ij, l) + &
116                 dt*dteta(ij,l)/masse(ij,l)                 dt*dteta(ij, l)/masse(ij, l)
117         END DO         END DO
118    
119         !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    .         ! Calcul de la valeur moyenne, unique aux poles pour teta
   
120    
121         DO ij = 1, iim         DO ij = 1, iim
122            tppn(ij) = aire(ij)*teta(ij,l)            tppn(ij) = aire(ij)*teta(ij, l)
123            tpps(ij) = aire(ij+ip1jm)*teta(ij+ip1jm,l)            tpps(ij) = aire(ij+ip1jm)*teta(ij+ip1jm, l)
124         END DO         END DO
125         tpn = ssum(iim,tppn,1)/apoln         tpn = ssum(iim, tppn, 1)/apoln
126         tps = ssum(iim,tpps,1)/apols         tps = ssum(iim, tpps, 1)/apols
127    
128         DO ij = 1, iip1         DO ij = 1, iip1
129            teta(ij,l) = tpn            teta(ij, l) = tpn
130            teta(ij+ip1jm,l) = tps            teta(ij+ip1jm, l) = tps
131         END DO         END DO
132    
   
133         IF (leapf) THEN         IF (leapf) THEN
134            CALL scopy(ip1jmp1,uscr(1),1,ucovm1(1,l),1)            CALL scopy(ip1jmp1, uscr(1), 1, ucovm1(1, l), 1)
135            CALL scopy(ip1jm,vscr(1),1,vcovm1(1,l),1)            CALL scopy(ip1jm, vscr(1), 1, vcovm1(1, l), 1)
136            CALL scopy(ip1jmp1,hscr(1),1,tetam1(1,l),1)            CALL scopy(ip1jmp1, hscr(1), 1, tetam1(1, l), 1)
137         END IF         END IF
   
138      END DO      END DO
139    
140      DO l = 1, llm      DO l = 1, llm
141         DO ij = 1, ip1jmp1         DO ij = 1, ip1jmp1
142            deltap(ij,l) = p(ij,l) - p(ij,l+1)            deltap(ij, l) = p(ij, l) - p(ij, l+1)
143         END DO         END DO
144      END DO      END DO
145    
146      CALL qminimum(q,nq,deltap)      CALL qminimum(q, nq, deltap)
   
     !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....  
147    
148        ! Calcul de la valeur moyenne, unique aux poles pour q
149    
150      DO iq = 1, nq      DO iq = 1, nq
151         DO l = 1, llm         DO l = 1, llm
   
152            DO ij = 1, iim            DO ij = 1, iim
153               qppn(ij) = aire(ij)*q(ij,l,iq)               qppn(ij) = aire(ij)*q(ij, 1, l, iq)
154               qpps(ij) = aire(ij+ip1jm)*q(ij+ip1jm,l,iq)               qpps(ij) = aire(ij+ip1jm)*q(ij, jjm + 1, l, iq)
155            END DO            END DO
156            qpn = ssum(iim,qppn,1)/apoln            qpn = ssum(iim, qppn, 1)/apoln
157            qps = ssum(iim,qpps,1)/apols            qps = ssum(iim, qpps, 1)/apols
158    
159            DO ij = 1, iip1            DO ij = 1, iip1
160               q(ij,l,iq) = qpn               q(ij, 1, l, iq) = qpn
161               q(ij+ip1jm,l,iq) = qps               q(ij, jjm + 1, l, iq) = qps
162            END DO            END DO
   
163         END DO         END DO
164      END DO      END DO
165    
166        CALL scopy(ijp1llm, finvmasse, 1, finvmaold, 1)
167    
168      CALL scopy(ijp1llm,finvmasse,1,finvmaold,1)      ! Fin de l'integration de q
   
   
     !     .....   FIN  de l'integration  de   q    .......                    
169    
170      IF (leapf) THEN      IF (leapf) THEN
171         CALL scopy(ip1jmp1,pscr,1,psm1,1)         CALL scopy(ip1jmp1, pscr, 1, psm1, 1)
172         CALL scopy(ip1jmp1*llm,massescr,1,massem1,1)         CALL scopy(ip1jmp1*llm, massescr, 1, massem1, 1)
173      END IF      END IF
174    
175    END SUBROUTINE integrd    END SUBROUTINE integrd
Legend:
Removed from v.32  
changed lines
  Added in v.40
  ViewVC Help
Powered by ViewVC 1.1.21