trunk/dyn3d/integrd.f

module integrd_m

  IMPLICIT NONE

contains

  SUBROUTINE integrd(nq,vcovm1,ucovm1,tetam1,psm1,massem1,dv,du,dteta,dp, &
       vcov,ucov,teta,q,ps,masse,finvmaold,leapf, dt)

    ! From dyn3d/integrd.F,v 1.1.1.1 2004/05/19 12:53:05
    !   Auteur:  P. Le Van                                                  
    !   objet:                                                              
    !   Incrementation des tendances dynamiques                             

    USE dimens_m, ONLY : iim, llm
    USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1, llmp1
    USE comvert, ONLY : ap, bp
    USE comgeom, ONLY : aire, apoln, apols
    USE pression_m, ONLY : pression
    USE filtreg_m, ONLY : filtreg

    !   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)

    REAL dv(ip1jm,llm), du(ip1jmp1,llm)
    REAL dteta(ip1jmp1,llm), dp(ip1jmp1)
    REAL finvmaold(ip1jmp1,llm)
    LOGICAL, INTENT (IN) :: leapf
    real, intent(in):: dt

    !   Local:                                                              

    REAL vscr(ip1jm), uscr(ip1jmp1), hscr(ip1jmp1), pscr(ip1jmp1)
    REAL massescr(ip1jmp1,llm), finvmasse(ip1jmp1,llm)
    REAL p(ip1jmp1,llmp1)
    REAL tpn, tps, tppn(iim), tpps(iim)
    REAL qpn, qps, qppn(iim), qpps(iim)
    REAL deltap(ip1jmp1,llm)

    INTEGER l, ij, iq

    REAL ssum

    !-----------------------------------------------------------------------

    DO l = 1, llm
       DO ij = 1, iip1
          ucov(ij,l) = 0.
          ucov(ij+ip1jm,l) = 0.
          uscr(ij) = 0.
          uscr(ij+ip1jm) = 0.
       END DO
    END DO


    !    ............    integration  de       ps         ..............    

    CALL scopy(ip1jmp1*llm,masse,1,massescr,1)

    DO ij = 1, ip1jmp1
       pscr(ij) = ps(ij)
       ps(ij) = psm1(ij) + dt*dp(ij)
    END DO

    DO ij = 1, ip1jmp1
       IF (ps(ij)<0.) THEN
          PRINT *, ' Au point ij = ', ij, ' , pression sol neg. ', ps(ij)
          STOP 'integrd'
       END IF
    END DO

    DO ij = 1, iim
       tppn(ij) = aire(ij)*ps(ij)
       tpps(ij) = aire(ij+ip1jm)*ps(ij+ip1jm)
    END DO
    tpn = ssum(iim,tppn,1)/apoln
    tps = ssum(iim,tpps,1)/apols
    DO ij = 1, iip1
       ps(ij) = tpn
       ps(ij+ip1jm) = tps
    END DO

    !  ... 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)


    !    ............   integration  de  ucov, vcov,  h     ..............  

    DO  l = 1, llm

       DO ij = iip2, ip1jm
          uscr(ij) = ucov(ij,l)
          ucov(ij,l) = ucovm1(ij,l) + dt*du(ij,l)
       END DO

       DO ij = 1, ip1jm
          vscr(ij) = vcov(ij,l)
          vcov(ij,l) = vcovm1(ij,l) + dt*dv(ij,l)
       END DO

       DO ij = 1, ip1jmp1
          hscr(ij) = teta(ij,l)
          teta(ij,l) = tetam1(ij,l)*massem1(ij,l)/masse(ij,l) + &
               dt*dteta(ij,l)/masse(ij,l)
       END DO

       !   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    .


       DO ij = 1, iim
          tppn(ij) = aire(ij)*teta(ij,l)
          tpps(ij) = aire(ij+ip1jm)*teta(ij+ip1jm,l)
       END DO
       tpn = ssum(iim,tppn,1)/apoln
       tps = ssum(iim,tpps,1)/apols

       DO ij = 1, iip1
          teta(ij,l) = tpn
          teta(ij+ip1jm,l) = tps
       END DO


       IF (leapf) THEN
          CALL scopy(ip1jmp1,uscr(1),1,ucovm1(1,l),1)
          CALL scopy(ip1jm,vscr(1),1,vcovm1(1,l),1)
          CALL scopy(ip1jmp1,hscr(1),1,tetam1(1,l),1)
       END IF

    END DO

    DO l = 1, llm
       DO ij = 1, ip1jmp1
          deltap(ij,l) = p(ij,l) - p(ij,l+1)
       END DO
    END DO

    CALL qminimum(q,nq,deltap)

    !    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....


    DO iq = 1, nq
       DO l = 1, llm

          DO ij = 1, iim
             qppn(ij) = aire(ij)*q(ij,l,iq)
             qpps(ij) = aire(ij+ip1jm)*q(ij+ip1jm,l,iq)
          END DO
          qpn = ssum(iim,qppn,1)/apoln
          qps = ssum(iim,qpps,1)/apols

          DO ij = 1, iip1
             q(ij,l,iq) = qpn
             q(ij+ip1jm,l,iq) = qps
          END DO

       END DO
    END DO


    CALL scopy(ijp1llm,finvmasse,1,finvmaold,1)


    !     .....   FIN  de l'integration  de   q    .......                  

    IF (leapf) THEN
       CALL scopy(ip1jmp1,pscr,1,psm1,1)
       CALL scopy(ip1jmp1*llm,massescr,1,massem1,1)
    END IF

  END SUBROUTINE integrd

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