trunk/dyn3d/addfi.f

module addfi_m

  IMPLICIT NONE

contains

  SUBROUTINE addfi(ucov, vcov, teta, q, ps, dufi, dvfi, dtetafi, dqfi, dpfi)

    ! 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, jjm, llm, nqmx

    ! First and second components of the covariant velocity:
    REAL, intent(inout):: ucov((iim + 1) * (jjm + 1), llm)
    REAL, intent(inout):: vcov((iim + 1) * jjm, llm)

    REAL, intent(inout):: teta((iim + 1) * (jjm + 1), llm)
    ! potential temperature

    real, intent(inout):: q((iim + 1) * (jjm + 1), llm, nqmx)
    real, intent(inout):: ps((iim + 1) * (jjm + 1))

    ! Tendencies:
    REAL, intent(in):: dufi((iim + 1) * (jjm + 1), llm)
    REAL, intent(in):: dvfi((iim + 1) * jjm, llm)
    real, intent(in):: dtetafi((iim + 1) * (jjm + 1), llm)
    REAL, intent(in):: dqfi((iim + 1) * (jjm + 1), llm, nqmx)
    REAL, intent(in):: dpfi((iim + 1) * (jjm + 1))

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

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

    teta = teta + dtetafi * dtphys

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

       DO ij = 1, iim + 1
          teta(ij , k) = tpn
          teta(ij+(iim + 1) * jjm, k) = tps
       ENDDO
    ENDDO

    DO k = 1, llm
       DO j = iim + 2, (iim + 1) * jjm
          ucov(j, k)= ucov(j, k) + dufi(j, k) * dtphys
       ENDDO
    ENDDO

    vcov = vcov + dvfi * dtphys
    ps = ps + dpfi * dtphys

    DO iq = 1, 2
       DO k = 1, llm
          DO j = 1, (iim + 1) * (jjm + 1)
             q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys
             q(j, k, iq)= MAX(q(j, k, iq), qtestw)
          ENDDO
       ENDDO
    ENDDO

    DO iq = 3, nqmx
       DO k = 1, llm
          DO j = 1, (iim + 1) * (jjm + 1)
             q(j, k, iq)= q(j, k, iq) + dqfi(j, k, iq) * dtphys
             q(j, k, iq)= MAX(q(j, k, iq), qtestt)
          ENDDO
       ENDDO
    ENDDO

    DO ij = 1, iim
       xpn(ij) = aire(ij) * ps(ij)
       xps(ij) = aire(ij+(iim + 1) * jjm) * ps(ij+(iim + 1) * jjm)
    ENDDO
    tpn = SUM(xpn)/apoln
    tps = SUM(xps)/apols

    DO ij = 1, iim + 1
       ps(ij) = tpn
       ps(ij+(iim + 1) * jjm) = tps
    ENDDO

    DO iq = 1, nqmx
       DO k = 1, llm
          DO ij = 1, iim
             xpn(ij) = aire(ij) * q(ij , k, iq)
             xps(ij) = aire(ij+(iim + 1) * jjm) * q(ij+(iim + 1) * jjm, k, iq)
          ENDDO
          tpn = SUM(xpn)/apoln
          tps = SUM(xps)/apols

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