trunk/dyn3d/addfi.f

module addfi_m

  IMPLICIT NONE

contains

  SUBROUTINE addfi(nq, ucov, vcov, teta, pq, pps, dufi, dvfi, pdhfi, &
       pdqfi, pdpfi)

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

    ! Addition of the physical tendencies

    USE comconst, ONLY: dtphys
    USE comgeom, ONLY: aire, apoln, apols
    USE dimens_m, ONLY: iim, llm
    USE paramet_m, ONLY: iip1, iip2, ip1jm, ip1jmp1

    INTEGER, intent(in):: nq

    REAL, intent(inout):: ucov(ip1jmp1, llm), vcov(ip1jm, llm)
    ! first and second components of the covariant velocity

    REAL, intent(inout):: teta(ip1jmp1, llm) ! potential temperature
    real, intent(inout):: pq(ip1jmp1, llm, nq), pps(ip1jmp1)
    REAL, intent(in):: dufi(ip1jmp1, llm), dvfi(ip1jm, llm) ! tendencies
    real, intent(in):: pdhfi(ip1jmp1, llm) ! tendency
    REAL, intent(in):: pdqfi(ip1jmp1, llm, nq), pdpfi(ip1jmp1)

    ! Local variables :
    REAL xpn(iim), xps(iim), tpn, tps
    INTEGER j, k, iq, ij
    REAL, PARAMETER:: qtestw = 1e-15, qtestt = 1e-40

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

    DO k = 1, llm
       DO j = 1, ip1jmp1
          teta(j, k)= teta(j, k) + pdhfi(j, k) * dtphys
       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 = SUM(xpn)/ apoln
       tps = SUM(xps)/ apols

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

    DO k = 1, llm
       DO j = iip2, ip1jm
          ucov(j, k)= ucov(j, k) + dufi(j, k) * dtphys
       ENDDO
    ENDDO

    DO k = 1, llm
       DO j = 1, ip1jm
          vcov(j, k)= vcov(j, k) + dvfi(j, k) * dtphys
       ENDDO
    ENDDO

    DO j = 1, ip1jmp1
       pps(j) = pps(j) + pdpfi(j) * dtphys
    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) * dtphys
             pq(j, k, iq)= MAX(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) * dtphys
             pq(j, k, iq)= MAX(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 = SUM(xpn)/apoln
    tps = SUM(xps)/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 = SUM(xpn)/apoln
          tps = SUM(xps)/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	70	SUBROUTINE addfi(nq, ucov, vcov, teta, pq, pps, dufi, dvfi, pdhfi, &
8	guez	37	pdqfi, pdpfi)
9	guez	3
10	guez	70	! From dyn3d/addfi.F, v 1.1.1.1 2004/05/19 12:53:06
11	guez	3
12	guez	70	! Addition of the physical tendencies
13	guez	37
14	guez	70	USE comconst, ONLY: dtphys
15			USE comgeom, ONLY: aire, apoln, apols
16			USE dimens_m, ONLY: iim, llm
17			USE paramet_m, ONLY: iip1, iip2, ip1jm, ip1jmp1
18	guez	37
19	guez	70	INTEGER, intent(in):: nq
20	guez	37
21	guez	70	REAL, intent(inout):: ucov(ip1jmp1, llm), vcov(ip1jm, llm)
22			! first and second components of the covariant velocity
23	guez	37
24	guez	70	REAL, intent(inout):: teta(ip1jmp1, llm) ! potential temperature
25			real, intent(inout):: pq(ip1jmp1, llm, nq), pps(ip1jmp1)
26			REAL, intent(in):: dufi(ip1jmp1, llm), dvfi(ip1jm, llm) ! tendencies
27			real, intent(in):: pdhfi(ip1jmp1, llm) ! tendency
28			REAL, intent(in):: pdqfi(ip1jmp1, llm, nq), pdpfi(ip1jmp1)
29	guez	37
30	guez	70	! Local variables :
31			REAL xpn(iim), xps(iim), tpn, tps
32			INTEGER j, k, iq, ij
33			REAL, PARAMETER:: qtestw = 1e-15, qtestt = 1e-40
34	guez	37
35			!-----------------------------------------------------------------------
36
37	guez	70	DO k = 1, llm
38			DO j = 1, ip1jmp1
39			teta(j, k)= teta(j, k) + pdhfi(j, k) * dtphys
40	guez	37	ENDDO
41			ENDDO
42
43	guez	70	DO k = 1, llm
44			DO ij = 1, iim
45			xpn(ij) = aire(ij) * teta(ij , k)
46			xps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm, k)
47	guez	3	ENDDO
48	guez	70	tpn = SUM(xpn)/ apoln
49			tps = SUM(xps)/ apols
50	guez	3
51	guez	70	DO ij = 1, iip1
52			teta(ij , k) = tpn
53			teta(ij+ip1jm, k) = tps
54	guez	3	ENDDO
55	guez	37	ENDDO
56	guez	3
57	guez	70	DO k = 1, llm
58			DO j = iip2, ip1jm
59			ucov(j, k)= ucov(j, k) + dufi(j, k) * dtphys
60	guez	37	ENDDO
61			ENDDO
62	guez	3
63	guez	70	DO k = 1, llm
64			DO j = 1, ip1jm
65			vcov(j, k)= vcov(j, k) + dvfi(j, k) * dtphys
66	guez	37	ENDDO
67			ENDDO
68	guez	3
69	guez	70	DO j = 1, ip1jmp1
70			pps(j) = pps(j) + pdpfi(j) * dtphys
71	guez	37	ENDDO
72	guez	3
73	guez	37	DO iq = 1, 2
74	guez	70	DO k = 1, llm
75			DO j = 1, ip1jmp1
76			pq(j, k, iq)= pq(j, k, iq) + pdqfi(j, k, iq) * dtphys
77			pq(j, k, iq)= MAX(pq(j, k, iq), qtestw)
78	guez	37	ENDDO
79			ENDDO
80			ENDDO
81	guez	3
82	guez	37	DO iq = 3, nq
83	guez	70	DO k = 1, llm
84			DO j = 1, ip1jmp1
85			pq(j, k, iq)= pq(j, k, iq) + pdqfi(j, k, iq) * dtphys
86			pq(j, k, iq)= MAX(pq(j, k, iq), qtestt)
87	guez	37	ENDDO
88			ENDDO
89			ENDDO
90	guez	3
91	guez	70	DO ij = 1, iim
92			xpn(ij) = aire(ij) * pps(ij)
93			xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm)
94	guez	37	ENDDO
95	guez	70	tpn = SUM(xpn)/apoln
96			tps = SUM(xps)/apols
97	guez	3
98	guez	70	DO ij = 1, iip1
99			pps (ij) = tpn
100			pps (ij+ip1jm) = tps
101	guez	37	ENDDO
102	guez	3
103	guez	37	DO iq = 1, nq
104	guez	70	DO k = 1, llm
105			DO ij = 1, iim
106			xpn(ij) = aire(ij) * pq(ij , k, iq)
107			xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm, k, iq)
108	guez	3	ENDDO
109	guez	70	tpn = SUM(xpn)/apoln
110			tps = SUM(xps)/apols
111	guez	3
112	guez	70	DO ij = 1, iip1
113			pq (ij , k, iq) = tpn
114			pq (ij+ip1jm, k, iq) = tps
115	guez	3	ENDDO
116	guez	37	ENDDO
117			ENDDO
118	guez	3
119	guez	37	END SUBROUTINE addfi
120
121			end module addfi_m