trunk/dyn3d/sortvarc0.f

module sortvarc0_m

  IMPLICIT NONE

contains

  SUBROUTINE sortvarc0(ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp)

    ! From dyn3d/sortvarc0.F, version 1.1.1.1 2004/05/19 12:53:07
    ! Author: P. Le Van
    ! Objet : sortie des variables de contrôle

    USE comconst, ONLY: daysec, g, omeg, rad
    USE comgeom, ONLY: aire, cu, rlatu
    USE dimens_m, ONLY: iim, jjm, llm
    USE ener, ONLY: ang0, etot0, ptot0, rmsdpdt, rmsv, stot0, ztot0
    use filtreg_m, only: filtreg
    use massbarxy_m, only: massbarxy
    USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1

    REAL, INTENT(IN):: ucov(ip1jmp1, llm)
    REAL, INTENT(IN):: teta(ip1jmp1, llm)
    REAL, INTENT(IN):: ps(ip1jmp1)
    REAL, INTENT(IN):: masse(ip1jmp1, llm)
    REAL, INTENT(IN):: pk(ip1jmp1, llm)
    REAL, INTENT(IN):: phis(ip1jmp1)
    REAL, INTENT(IN):: vorpot(ip1jm, llm)
    REAL, intent(in):: phi(ip1jmp1, llm)
    real, intent(in):: bern(ip1jmp1, llm)
    REAL, intent(in):: dp(ip1jmp1)

    ! Local:
    REAL:: vor(ip1jm), bernf(ip1jmp1, llm), ztotl(llm)
    REAL:: etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(ip1jmp1)
    REAL:: cosphi(ip1jm), omegcosp(ip1jm)
    REAL radsg, radomeg
    REAL massebxy(ip1jm, llm)
    INTEGER l, ij
    REAL ssum

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

    PRINT *, "Call sequence information: sortvarc0"

    CALL massbarxy(masse, massebxy)

    ! Calcul  de  rmsdpdt
    ge = dp*dp
    rmsdpdt = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
    rmsdpdt = daysec*1.E-2*sqrt(rmsdpdt / (iim * jjp1))
    bernf = bern
    CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)

    ! Calcul du moment  angulaire
    radsg = rad/g
    radomeg = rad*omeg
    DO ij = iip2, ip1jm
       cosphi(ij) = cos(rlatu((ij-1)/iip1+1))
       omegcosp(ij) = radomeg*cosphi(ij)
    END DO

    ! Calcul  de l'energie, de l'enstrophie, de l'entropie et de rmsv

    DO l = 1, llm
       DO ij = 1, ip1jm
          vor(ij) = vorpot(ij, l)*vorpot(ij, l)*massebxy(ij, l)
       END DO
       ztotl(l) = (ssum(ip1jm, vor, 1)-ssum(jjm, vor, iip1))

       DO ij = 1, ip1jmp1
          ge(ij) = masse(ij, l) * (phis(ij) + teta(ij, l) * pk(ij, l) &
               + bernf(ij, l)-phi(ij, l))
       END DO
       etotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)

       DO ij = 1, ip1jmp1
          ge(ij) = masse(ij, l)*teta(ij, l)
       END DO
       stotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)

       DO ij = 1, ip1jmp1
          ge(ij) = masse(ij, l)*amax1(bernf(ij, l)-phi(ij, l), 0.)
       END DO
       rmsvl(l) = 2.*(ssum(ip1jmp1, ge, 1)-ssum(jjp1, ge, iip1))

       DO ij = iip2, ip1jm
          ge(ij) = (ucov(ij, l)/cu(ij)+omegcosp(ij))*masse(ij, l)*cosphi(ij)
       END DO
       angl(l) = radsg * (ssum(ip1jm-iip1, ge(iip2), 1) &
            - ssum(jjm-1, ge(iip2), iip1))
    END DO

    DO ij = 1, ip1jmp1
       ge(ij) = ps(ij)*aire(ij)
    END DO
    ptot0 = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
    etot0 = ssum(llm, etotl, 1)
    ztot0 = ssum(llm, ztotl, 1)
    stot0 = ssum(llm, stotl, 1)
    rmsv = ssum(llm, rmsvl, 1)
    ang0 = ssum(llm, angl, 1)

    PRINT *, 'ptot0 = ', ptot0
    PRINT *, 'etot0 = ', etot0
    PRINT *, 'ztot0 = ', ztot0
    PRINT *, 'stot0 = ', stot0
    PRINT *, 'ang0 = ', ang0

  END SUBROUTINE sortvarc0

end module sortvarc0_m
1	guez	78	module sortvarc0_m
2	guez	3
3	guez	23	IMPLICIT NONE
4	guez	3
5	guez	78	contains
6	guez	3
7	guez	78	SUBROUTINE sortvarc0(ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp)
8	guez	3
9	guez	78	! From dyn3d/sortvarc0.F, version 1.1.1.1 2004/05/19 12:53:07
10			! Author: P. Le Van
11			! Objet : sortie des variables de contrôle
12	guez	3
13	guez	78	USE comconst, ONLY: daysec, g, omeg, rad
14			USE comgeom, ONLY: aire, cu, rlatu
15			USE dimens_m, ONLY: iim, jjm, llm
16			USE ener, ONLY: ang0, etot0, ptot0, rmsdpdt, rmsv, stot0, ztot0
17			use filtreg_m, only: filtreg
18			use massbarxy_m, only: massbarxy
19			USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1
20	guez	3
21	guez	78	REAL, INTENT(IN):: ucov(ip1jmp1, llm)
22			REAL, INTENT(IN):: teta(ip1jmp1, llm)
23			REAL, INTENT(IN):: ps(ip1jmp1)
24			REAL, INTENT(IN):: masse(ip1jmp1, llm)
25			REAL, INTENT(IN):: pk(ip1jmp1, llm)
26			REAL, INTENT(IN):: phis(ip1jmp1)
27			REAL, INTENT(IN):: vorpot(ip1jm, llm)
28			REAL, intent(in):: phi(ip1jmp1, llm)
29			real, intent(in):: bern(ip1jmp1, llm)
30			REAL, intent(in):: dp(ip1jmp1)
31	guez	3
32	guez	78	! Local:
33			REAL:: vor(ip1jm), bernf(ip1jmp1, llm), ztotl(llm)
34			REAL:: etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(ip1jmp1)
35			REAL:: cosphi(ip1jm), omegcosp(ip1jm)
36			REAL radsg, radomeg
37			REAL massebxy(ip1jm, llm)
38			INTEGER l, ij
39			REAL ssum
40	guez	3
41	guez	78	!-----------------------------------------------------------------------
42	guez	3
43	guez	78	PRINT *, "Call sequence information: sortvarc0"
44	guez	3
45	guez	78	CALL massbarxy(masse, massebxy)
46	guez	3
47	guez	78	! Calcul de rmsdpdt
48			ge = dp*dp
49			rmsdpdt = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
50			rmsdpdt = daysec1.E-2sqrt(rmsdpdt / (iim * jjp1))
51			bernf = bern
52			CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)
53	guez	3
54	guez	78	! Calcul du moment angulaire
55			radsg = rad/g
56			radomeg = rad*omeg
57			DO ij = iip2, ip1jm
58			cosphi(ij) = cos(rlatu((ij-1)/iip1+1))
59			omegcosp(ij) = radomeg*cosphi(ij)
60			END DO
61	guez	3
62	guez	78	! Calcul de l'energie, de l'enstrophie, de l'entropie et de rmsv
63	guez	3
64	guez	78	DO l = 1, llm
65			DO ij = 1, ip1jm
66			vor(ij) = vorpot(ij, l)vorpot(ij, l)massebxy(ij, l)
67			END DO
68			ztotl(l) = (ssum(ip1jm, vor, 1)-ssum(jjm, vor, iip1))
69	guez	3
70	guez	78	DO ij = 1, ip1jmp1
71			ge(ij) = masse(ij, l) * (phis(ij) + teta(ij, l) * pk(ij, l) &
72			+ bernf(ij, l)-phi(ij, l))
73			END DO
74			etotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
75	guez	3
76	guez	78	DO ij = 1, ip1jmp1
77			ge(ij) = masse(ij, l)*teta(ij, l)
78			END DO
79			stotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
80	guez	3
81	guez	78	DO ij = 1, ip1jmp1
82			ge(ij) = masse(ij, l)*amax1(bernf(ij, l)-phi(ij, l), 0.)
83			END DO
84			rmsvl(l) = 2.*(ssum(ip1jmp1, ge, 1)-ssum(jjp1, ge, iip1))
85	guez	3
86	guez	78	DO ij = iip2, ip1jm
87			ge(ij) = (ucov(ij, l)/cu(ij)+omegcosp(ij))masse(ij, l)cosphi(ij)
88			END DO
89			angl(l) = radsg * (ssum(ip1jm-iip1, ge(iip2), 1) &
90			- ssum(jjm-1, ge(iip2), iip1))
91			END DO
92	guez	3
93	guez	78	DO ij = 1, ip1jmp1
94			ge(ij) = ps(ij)*aire(ij)
95			END DO
96			ptot0 = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
97			etot0 = ssum(llm, etotl, 1)
98			ztot0 = ssum(llm, ztotl, 1)
99			stot0 = ssum(llm, stotl, 1)
100			rmsv = ssum(llm, rmsvl, 1)
101			ang0 = ssum(llm, angl, 1)
102	guez	3
103	guez	78	PRINT *, 'ptot0 = ', ptot0
104			PRINT *, 'etot0 = ', etot0
105			PRINT *, 'ztot0 = ', ztot0
106			PRINT *, 'stot0 = ', stot0
107			PRINT *, 'ang0 = ', ang0
108	guez	3
109	guez	78	END SUBROUTINE sortvarc0
110	guez	3
111	guez	78	end module sortvarc0_m