trunk/dyn3d/sortvarc.f

module sortvarc_m

  IMPLICIT NONE

contains

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

    ! 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, dtvr, g, omeg, rad
    USE comgeom, ONLY: aire, cu, rlatu
    USE conf_gcm_m, ONLY: day_step
    USE dimens_m, ONLY: iim, jjm, llm
    USE dynetat0_m, ONLY: day_ini
    USE ener, ONLY: ang, ang0, etot, etot0, ptot, ptot0, rmsdpdt, rmsv, &
         stot, stot0, ztot, ztot0
    use filtreg_m, only: filtreg
    use massbarxy_m, only: massbarxy
    USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1

    INTEGER, INTENT(IN):: itau
    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)
    REAL, INTENT (IN):: time_0

    ! 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 dtvrs1j, rjour, heure, radsg, radomeg
    REAL massebxy(ip1jm, llm)
    INTEGER l, ij
    REAL ssum
    real time

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

    PRINT *, "Call sequence information: sortvarc"

    time = real(itau) / day_step + time_0
    dtvrs1j = dtvr/daysec
    rjour = real(int(itau*dtvrs1j))
    heure = (itau*dtvrs1j-rjour)*24.
    IF (abs(heure-24.)<=0.0001) heure = 0.

    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
    ptot = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
    etot = ssum(llm, etotl, 1)
    ztot = ssum(llm, ztotl, 1)
    stot = ssum(llm, stotl, 1)
    rmsv = ssum(llm, rmsvl, 1)
    ang = ssum(llm, angl, 1)

    IF (ptot0 == 0.) THEN
       PRINT *, 'WARNING!!! On recalcule les valeurs initiales de :'
       PRINT *, 'ptot, rmsdpdt, etot, ztot, stot, rmsv, ang'
       PRINT *, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang
       etot0 = etot
       ptot0 = ptot
       ztot0 = ztot
       stot0 = stot
       ang0 = ang
    END IF

    etot = etot/etot0
    rmsv = sqrt(rmsv/ptot)
    ptot = ptot/ptot0
    ztot = ztot/ztot0
    stot = stot/stot0
    ang = ang/ang0

    PRINT 3500, itau, int(day_ini + time), heure, time
    PRINT 4000, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang

3500 FORMAT (4X, 'pas', I7, 5X, 'jour', i5, 1X, 'heure', F5.1, 4X, 'date', &
          F10.5)
4000 FORMAT (10X, 'masse', 4X, 'rmsdpdt', 7X, 'energie', 2X, 'enstrophie', &
          2X, 'entropie', 3X, 'rmsv', 4X, 'mt.ang', /, 'GLOB  ', F10.6, &
          E13.6, 5F10.3/)

  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	33	contains
6	guez	3
7	guez	33	SUBROUTINE sortvarc(itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, &
8			bern, dp, time_0)
9	guez	3
10	guez	33	! From dyn3d/sortvarc.F, version 1.1.1.1 2004/05/19 12:53:07
11			! Author: P. Le Van
12			! Objet : sortie des variables de contrôle
13	guez	3
14	guez	69	USE comconst, ONLY: daysec, dtvr, g, omeg, rad
15			USE comgeom, ONLY: aire, cu, rlatu
16	guez	33	USE conf_gcm_m, ONLY: day_step
17	guez	69	USE dimens_m, ONLY: iim, jjm, llm
18			USE dynetat0_m, ONLY: day_ini
19			USE ener, ONLY: ang, ang0, etot, etot0, ptot, ptot0, rmsdpdt, rmsv, &
20	guez	33	stot, stot0, ztot, ztot0
21			use filtreg_m, only: filtreg
22	guez	78	use massbarxy_m, only: massbarxy
23	guez	69	USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1
24	guez	3
25	guez	69	INTEGER, INTENT(IN):: itau
26			REAL, INTENT(IN):: ucov(ip1jmp1, llm)
27	guez	78	REAL, INTENT(IN):: teta(ip1jmp1, llm)
28	guez	69	REAL, INTENT(IN):: ps(ip1jmp1)
29			REAL, INTENT(IN):: masse(ip1jmp1, llm)
30	guez	78	REAL, INTENT(IN):: pk(ip1jmp1, llm)
31	guez	69	REAL, INTENT(IN):: phis(ip1jmp1)
32			REAL, INTENT(IN):: vorpot(ip1jm, llm)
33	guez	68	REAL, intent(in):: phi(ip1jmp1, llm)
34	guez	69	real, intent(in):: bern(ip1jmp1, llm)
35			REAL, intent(in):: dp(ip1jmp1)
36	guez	33	REAL, INTENT (IN):: time_0
37	guez	3
38	guez	33	! Local:
39	guez	69	REAL:: vor(ip1jm), bernf(ip1jmp1, llm), ztotl(llm)
40			REAL:: etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(ip1jmp1)
41			REAL:: cosphi(ip1jm), omegcosp(ip1jm)
42	guez	78	REAL dtvrs1j, rjour, heure, radsg, radomeg
43			REAL massebxy(ip1jm, llm)
44			INTEGER l, ij
45			REAL ssum
46	guez	33	real time
47	guez	3
48	guez	33	!-----------------------------------------------------------------------
49	guez	3
50	guez	78	PRINT *, "Call sequence information: sortvarc"
51	guez	57
52	guez	33	time = real(itau) / day_step + time_0
53			dtvrs1j = dtvr/daysec
54			rjour = real(int(itau*dtvrs1j))
55			heure = (itaudtvrs1j-rjour)24.
56			IF (abs(heure-24.)<=0.0001) heure = 0.
57	guez	3
58	guez	33	CALL massbarxy(masse, massebxy)
59	guez	3
60	guez	33	! Calcul de rmsdpdt
61	guez	78	ge = dp*dp
62	guez	33	rmsdpdt = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
63	guez	78	rmsdpdt = daysec1.E-2sqrt(rmsdpdt / (iim * jjp1))
64	guez	69	bernf = bern
65	guez	64	CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)
66	guez	3
67	guez	33	! Calcul du moment angulaire
68			radsg = rad/g
69			radomeg = rad*omeg
70			DO ij = iip2, ip1jm
71			cosphi(ij) = cos(rlatu((ij-1)/iip1+1))
72			omegcosp(ij) = radomeg*cosphi(ij)
73			END DO
74	guez	3
75	guez	33	! Calcul de l'energie, de l'enstrophie, de l'entropie et de rmsv
76	guez	78
77	guez	33	DO l = 1, llm
78			DO ij = 1, ip1jm
79			vor(ij) = vorpot(ij, l)vorpot(ij, l)massebxy(ij, l)
80			END DO
81			ztotl(l) = (ssum(ip1jm, vor, 1)-ssum(jjm, vor, iip1))
82	guez	3
83	guez	33	DO ij = 1, ip1jmp1
84			ge(ij) = masse(ij, l) * (phis(ij) + teta(ij, l) * pk(ij, l) &
85			+ bernf(ij, l)-phi(ij, l))
86			END DO
87			etotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
88	guez	3
89	guez	33	DO ij = 1, ip1jmp1
90			ge(ij) = masse(ij, l)*teta(ij, l)
91			END DO
92			stotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
93	guez	3
94	guez	33	DO ij = 1, ip1jmp1
95			ge(ij) = masse(ij, l)*amax1(bernf(ij, l)-phi(ij, l), 0.)
96			END DO
97			rmsvl(l) = 2.*(ssum(ip1jmp1, ge, 1)-ssum(jjp1, ge, iip1))
98	guez	3
99	guez	33	DO ij = iip2, ip1jm
100			ge(ij) = (ucov(ij, l)/cu(ij)+omegcosp(ij))masse(ij, l)cosphi(ij)
101			END DO
102			angl(l) = radsg * (ssum(ip1jm-iip1, ge(iip2), 1) &
103			- ssum(jjm-1, ge(iip2), iip1))
104			END DO
105	guez	3
106	guez	33	DO ij = 1, ip1jmp1
107			ge(ij) = ps(ij)*aire(ij)
108			END DO
109			ptot = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
110			etot = ssum(llm, etotl, 1)
111			ztot = ssum(llm, ztotl, 1)
112			stot = ssum(llm, stotl, 1)
113			rmsv = ssum(llm, rmsvl, 1)
114			ang = ssum(llm, angl, 1)
115	guez	3
116	guez	33	IF (ptot0 == 0.) THEN
117			PRINT *, 'WARNING!!! On recalcule les valeurs initiales de :'
118			PRINT *, 'ptot, rmsdpdt, etot, ztot, stot, rmsv, ang'
119			PRINT *, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang
120			etot0 = etot
121			ptot0 = ptot
122			ztot0 = ztot
123			stot0 = stot
124			ang0 = ang
125			END IF
126	guez	3
127	guez	33	etot = etot/etot0
128			rmsv = sqrt(rmsv/ptot)
129			ptot = ptot/ptot0
130			ztot = ztot/ztot0
131			stot = stot/stot0
132			ang = ang/ang0
133	guez	3
134	guez	33	PRINT 3500, itau, int(day_ini + time), heure, time
135			PRINT 4000, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang
136	guez	3
137	guez	33	3500 FORMAT (4X, 'pas', I7, 5X, 'jour', i5, 1X, 'heure', F5.1, 4X, 'date', &
138			F10.5)
139			4000 FORMAT (10X, 'masse', 4X, 'rmsdpdt', 7X, 'energie', 2X, 'enstrophie', &
140			2X, 'entropie', 3X, 'rmsv', 4X, 'mt.ang', /, 'GLOB ', F10.6, &
141			E13.6, 5F10.3/)
142	guez	3
143	guez	33	END SUBROUTINE sortvarc
144	guez	3
145	guez	33	end module sortvarc_m