libf/dyn3d/integrd.f90

SUBROUTINE integrd(nq,vcovm1,ucovm1,tetam1,psm1,massem1,dv,du,dteta,dq,dp, &
     vcov,ucov,teta,q,ps,masse,phis,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

  IMPLICIT NONE

  !   Arguments:                                                          

  INTEGER nq

  REAL vcov(ip1jm,llm), ucov(ip1jmp1,llm), teta(ip1jmp1,llm)
  REAL q(ip1jmp1,llm,nq)
  REAL ps(ip1jmp1), masse(ip1jmp1,llm), phis(ip1jmp1)

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