trunk/dyn3d/addfi.f

module addfi_m

  IMPLICIT NONE

contains

  SUBROUTINE addfi(nq, pdt, pucov, pvcov, teta, pq, pps, pdufi, pdvfi, pdhfi,&
       pdqfi, pdpfi)

    ! From dyn3d/addfi.F,v 1.1.1.1 2004/05/19 12:53:06

    !    Addition of the physical tendencies

    !    Interface :

    !      Input :

    !      pdt                    time step of integration
    !      pucov(ip1jmp1,llm)     first component of the covariant velocity
    !      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
    !      teta(ip1jmp1,llm)     potential temperature
    !      pts(ip1jmp1,llm)       surface temperature
    !      pdufi(ip1jmp1,llm)     |
    !      pdvfi(ip1jm,llm)       |   respective
    !      pdhfi(ip1jmp1)         |      tendencies
    !      pdtsfi(ip1jmp1)        |

    !      Output :

    !      pucov
    !      pvcov
    !      ph
    !      pts

    use dimens_m
    use paramet_m
    use comconst
    use comgeom
    use serre

    !    Arguments :

    INTEGER nq

    REAL pdt

    REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
    REAL, intent(inout):: teta(ip1jmp1,llm)
    real pq(ip1jmp1,llm,nq),pps(ip1jmp1)

    REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
    REAL pdqfi(ip1jmp1,llm,nq), pdpfi(ip1jmp1)
    real, intent(in):: pdhfi(ip1jmp1,llm)

    !    Local variables :

    REAL xpn(iim),xps(iim),tpn,tps
    INTEGER j,k,iq,ij
    REAL qtestw, qtestt
    PARAMETER ( qtestw = 1.0e-15 )
    PARAMETER ( qtestt = 1.0e-40 )

    REAL SSUM

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

    DO k = 1,llm
       DO j = 1,ip1jmp1
          teta(j,k)= teta(j,k) + pdhfi(j,k) * pdt
       ENDDO
    ENDDO

    DO  k    = 1, llm
       DO  ij   = 1, iim
          xpn(ij) = aire(   ij   ) * teta(  ij    ,k)
          xps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,k)
       ENDDO
       tpn      = SSUM(iim,xpn,1)/ apoln
       tps      = SSUM(iim,xps,1)/ apols

       DO ij   = 1, iip1
          teta(   ij   ,k)  = tpn
          teta(ij+ip1jm,k)  = tps
       ENDDO
    ENDDO

    DO k = 1,llm
       DO j = iip2,ip1jm
          pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
       ENDDO
    ENDDO

    DO k = 1,llm
       DO j = 1,ip1jm
          pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
       ENDDO
    ENDDO

    DO j = 1,ip1jmp1
       pps(j) = pps(j) + pdpfi(j) * pdt
    ENDDO

    DO iq = 1, 2
       DO k = 1,llm
          DO j = 1,ip1jmp1
             pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
             pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
          ENDDO
       ENDDO
    ENDDO

    DO iq = 3, nq
       DO k = 1,llm
          DO j = 1,ip1jmp1
             pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
             pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
          ENDDO
       ENDDO
    ENDDO

    DO  ij   = 1, iim
       xpn(ij) = aire(   ij   ) * pps(  ij     )
       xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
    ENDDO
    tpn      = SSUM(iim,xpn,1)/apoln
    tps      = SSUM(iim,xps,1)/apols

    DO ij   = 1, iip1
       pps (   ij     )  = tpn
       pps ( ij+ip1jm )  = tps
    ENDDO

    DO iq = 1, nq
       DO  k    = 1, llm
          DO  ij   = 1, iim
             xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
             xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
          ENDDO
          tpn      = SSUM(iim,xpn,1)/apoln
          tps      = SSUM(iim,xps,1)/apols

          DO ij   = 1, iip1
             pq (   ij   ,k,iq)  = tpn
             pq (ij+ip1jm,k,iq)  = tps
          ENDDO
       ENDDO
    ENDDO

  END SUBROUTINE addfi

end module addfi_m
1	guez	37	module addfi_m
2	guez	3
3	guez	37	IMPLICIT NONE
4	guez	3
5	guez	37	contains
6	guez	3
7	guez	44	SUBROUTINE addfi(nq, pdt, pucov, pvcov, teta, pq, pps, pdufi, pdvfi, pdhfi,&
8	guez	37	pdqfi, pdpfi)
9	guez	3
10	guez	37	! From dyn3d/addfi.F,v 1.1.1.1 2004/05/19 12:53:06
11	guez	3
12	guez	37	! Addition of the physical tendencies
13
14			! Interface :
15
16			! Input :
17
18			! pdt time step of integration
19			! pucov(ip1jmp1,llm) first component of the covariant velocity
20			! pvcov(ip1ip1jm,llm) second component of the covariant velocity
21	guez	44	! teta(ip1jmp1,llm) potential temperature
22	guez	37	! pts(ip1jmp1,llm) surface temperature
23			! pdufi(ip1jmp1,llm) \|
24			! pdvfi(ip1jm,llm) \| respective
25			! pdhfi(ip1jmp1) \| tendencies
26			! pdtsfi(ip1jmp1) \|
27
28			! Output :
29
30			! pucov
31			! pvcov
32			! ph
33			! pts
34
35			use dimens_m
36			use paramet_m
37			use comconst
38			use comgeom
39			use serre
40
41			! Arguments :
42
43			INTEGER nq
44
45			REAL pdt
46
47			REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
48	guez	44	REAL, intent(inout):: teta(ip1jmp1,llm)
49			real pq(ip1jmp1,llm,nq),pps(ip1jmp1)
50	guez	37
51			REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
52	guez	44	REAL pdqfi(ip1jmp1,llm,nq), pdpfi(ip1jmp1)
53			real, intent(in):: pdhfi(ip1jmp1,llm)
54	guez	37
55			! Local variables :
56
57			REAL xpn(iim),xps(iim),tpn,tps
58			INTEGER j,k,iq,ij
59			REAL qtestw, qtestt
60			PARAMETER ( qtestw = 1.0e-15 )
61			PARAMETER ( qtestt = 1.0e-40 )
62
63			REAL SSUM
64
65			!-----------------------------------------------------------------------
66
67			DO k = 1,llm
68			DO j = 1,ip1jmp1
69	guez	44	teta(j,k)= teta(j,k) + pdhfi(j,k) * pdt
70	guez	37	ENDDO
71			ENDDO
72
73			DO k = 1, llm
74	guez	3	DO ij = 1, iim
75	guez	44	xpn(ij) = aire( ij ) * teta( ij ,k)
76			xps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,k)
77	guez	3	ENDDO
78			tpn = SSUM(iim,xpn,1)/ apoln
79			tps = SSUM(iim,xps,1)/ apols
80
81			DO ij = 1, iip1
82	guez	44	teta( ij ,k) = tpn
83			teta(ij+ip1jm,k) = tps
84	guez	3	ENDDO
85	guez	37	ENDDO
86	guez	3
87	guez	37	DO k = 1,llm
88			DO j = iip2,ip1jm
89			pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
90			ENDDO
91			ENDDO
92	guez	3
93	guez	37	DO k = 1,llm
94			DO j = 1,ip1jm
95			pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
96			ENDDO
97			ENDDO
98	guez	3
99	guez	37	DO j = 1,ip1jmp1
100			pps(j) = pps(j) + pdpfi(j) * pdt
101			ENDDO
102	guez	3
103	guez	37	DO iq = 1, 2
104			DO k = 1,llm
105			DO j = 1,ip1jmp1
106			pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
107			pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
108			ENDDO
109			ENDDO
110			ENDDO
111	guez	3
112	guez	37	DO iq = 3, nq
113			DO k = 1,llm
114			DO j = 1,ip1jmp1
115			pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
116			pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt )
117			ENDDO
118			ENDDO
119			ENDDO
120	guez	3
121	guez	37	DO ij = 1, iim
122			xpn(ij) = aire( ij ) * pps( ij )
123			xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
124			ENDDO
125			tpn = SSUM(iim,xpn,1)/apoln
126			tps = SSUM(iim,xps,1)/apols
127	guez	3
128	guez	37	DO ij = 1, iip1
129			pps ( ij ) = tpn
130			pps ( ij+ip1jm ) = tps
131			ENDDO
132	guez	3
133	guez	37	DO iq = 1, nq
134			DO k = 1, llm
135	guez	3	DO ij = 1, iim
136	guez	37	xpn(ij) = aire( ij ) * pq( ij ,k,iq)
137			xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
138	guez	3	ENDDO
139			tpn = SSUM(iim,xpn,1)/apoln
140			tps = SSUM(iim,xps,1)/apols
141
142			DO ij = 1, iip1
143	guez	37	pq ( ij ,k,iq) = tpn
144			pq (ij+ip1jm,k,iq) = tps
145	guez	3	ENDDO
146	guez	37	ENDDO
147			ENDDO
148	guez	3
149	guez	37	END SUBROUTINE addfi
150
151			end module addfi_m