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\^ole

    USE comconst, ONLY: daysec, g, omeg, rad
    USE comgeom, ONLY: aire_2d, cu_2d
    USE dimens_m, ONLY: iim, jjm, llm
    use dynetat0_m, ONLY: rlatu
    USE ener, ONLY: ang0, etot0, ptot0, stot0, ztot0
    use filtreg_scal_m, only: filtreg_scal
    use massbarxy_m, only: massbarxy
    USE paramet_m, ONLY: 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(:, :, :) ! (iim + 1, jjm, 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 bernf(iim + 1, jjm + 1, llm)
    REAL etotl(llm), angl(llm), ge(iim, 2:jjm)
    REAL cosphi(2:jjm)
    REAL radsg, radomeg
    REAL massebxy(iim + 1, jjm, llm)
    INTEGER j, l

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

    PRINT *, "Call sequence information: sortvarc"

    rmsdpdt = daysec * 0.01 * sqrt(sum(dp(:iim, :)**2) / (iim * jjp1))

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

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

    ang = sum(angl)

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

    bernf = bern
    CALL filtreg_scal(bernf, direct = .false., intensive = .false.)

    ptot = sum(ps(:iim, :) * aire_2d(:iim, :))

    forall (l = 1:llm) etotl(l) = sum(masse(:iim, :, l) * (phis(:iim, :) &
         + teta(:iim, :, l) * pk(:iim, :, l) + bernf(:iim, :, l) &
         - phi(:iim, :, l)))
    etot = sum(etotl)

    CALL massbarxy(masse, massebxy)
    ztot = sum(vorpot(:iim, :, :)**2 * massebxy(:iim, :, :))

    stot = sum(masse(:iim, :, :) * teta(:iim, :, :))
    rmsv = 2. &
         * sum(masse(:iim, :, :) * max(bernf(:iim, :, :) - phi(:iim, :, :), 0.))

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