trunk/dyn3d/sortvarc.f

module sortvarc_m

  IMPLICIT NONE

  real, save:: ang, etot, ptot, ztot, stot, rmsdpdt, rmsv

contains

  SUBROUTINE sortvarc(ucov, teta, ps, masse, pk, phis, vorpot, phi, &
       bern, dp, resetvarc)

    ! From dyn3d/sortvarc.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_2d, cu_2d, rlatu
    USE dimens_m, ONLY: iim, jjm, llm
    USE ener, ONLY: ang0, etot0, ptot0, stot0, ztot0
    use filtreg_m, only: filtreg
    use massbarxy_m, only: massbarxy
    USE paramet_m, ONLY: iip1, ip1jm, jjp1

    REAL, INTENT(IN):: ucov(iim + 1, jjm + 1, llm)
    REAL, INTENT(IN):: teta(iim + 1, jjm + 1, llm)
    REAL, INTENT(IN):: ps(iim + 1, jjm + 1)
    REAL, INTENT(IN):: masse(iim + 1, jjm + 1, llm)
    REAL, INTENT(IN):: pk(iim + 1, jjm + 1, llm)
    REAL, INTENT(IN):: phis(iim + 1, jjm + 1)
    REAL, INTENT(IN):: vorpot(ip1jm, llm)
    REAL, intent(in):: phi(iim + 1, jjm + 1, llm)
    real, intent(in):: bern(iim + 1, jjm + 1, llm)
    REAL, intent(in):: dp(iim + 1, jjm + 1)
    logical, intent(in):: resetvarc

    ! Local:
    REAL vor(ip1jm), bernf(iim + 1, jjm + 1, llm), ztotl(llm)
    REAL etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(iim + 1, jjm + 1)
    REAL cosphi(2:jjm)
    REAL radsg, radomeg
    REAL massebxy(ip1jm, llm)
    INTEGER j, l, ij
    REAL ssum

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

    PRINT *, "Call sequence information: sortvarc"

    CALL massbarxy(masse, massebxy)

    ! Calcul  de  rmsdpdt
    ge = dp*dp
    rmsdpdt = sum(ge) - sum(ge(1, :))
    rmsdpdt = daysec*1.E-2*sqrt(rmsdpdt / (iim * jjp1))
    bernf = bern
    CALL filtreg(bernf, direct = .false., intensive = .false.)

    ! Calcul du moment  angulaire
    radsg = rad/g
    radomeg = rad*omeg
    cosphi = cos(rlatu(2:jjm))

    ! 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))

       ge = masse(:, :, l) * (phis + teta(:, :, l) * pk(:, :, l) &
            + bernf(:, :, l) - phi(:, :, l))
       etotl(l) = sum(ge) - sum(ge(1, :))

       ge = masse(:, :, l)*teta(:, :, l)
       stotl(l) = sum(ge) - sum(ge(1, :))

       ge = masse(:, :, l) * max(bernf(:, :, l) - phi(:, :, l), 0.)
       rmsvl(l) = 2.*(sum(ge)-sum(ge(1, :)))

       forall (j = 2:jjm) ge(:, j) = (ucov(:, j, l) / cu_2d(:, j) &
            + radomeg * cosphi(j)) * masse(:, j, l) * cosphi(j)
       angl(l) = radsg * (sum(ge(:, 2:jjm)) - sum(ge(1, 2:jjm)))
    END DO

    ge = ps * aire_2d
    ptot = sum(ge) - sum(ge(1, :))
    etot = sum(etotl)
    ztot = sum(ztotl)
    stot = sum(stotl)
    rmsv = sum(rmsvl)
    ang = sum(angl)

    IF (resetvarc .or. ptot0 == 0.) then
       print *, 'sortvarc: recomputed initial values.'
       etot0 = etot
       ptot0 = ptot
       ztot0 = ztot
       stot0 = stot
       ang0  = ang
       PRINT *, 'ptot0 = ', ptot0
       PRINT *, 'etot0 = ', etot0
       PRINT *, 'ztot0 = ', ztot0
       PRINT *, 'stot0 = ', stot0
       PRINT *, 'ang0 = ', ang0
    END IF

    IF (.not. resetvarc) then
       etot = etot/etot0
       rmsv = sqrt(rmsv/ptot)
       ptot = ptot/ptot0
       ztot = ztot/ztot0
       stot = stot/stot0
       ang = ang/ang0
    end IF

  END SUBROUTINE sortvarc

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