libf/dyn3d/sortvarc.f90

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 conf_gcm_m, ONLY: day_step
    USE dimens_m, ONLY : iim, jjm, llm
    USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1
    USE comconst, ONLY : daysec, dtvr, g, omeg, rad
    USE comgeom, ONLY : aire, cu, rlatu
    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

    ! Arguments:
    INTEGER, INTENT (IN) :: itau
    REAL :: ucov(ip1jmp1, llm), teta(ip1jmp1, llm), masse(ip1jmp1, llm)
    REAL :: ps(ip1jmp1), phis(ip1jmp1)
    REAL :: vorpot(ip1jm, llm)
    REAL :: phi(ip1jmp1, llm), bern(ip1jmp1, llm)
    REAL :: dp(ip1jmp1)
    REAL, INTENT (IN):: time_0
    REAL, INTENT (IN):: pk(ip1jmp1, llm)

    ! 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, imjmp1
    REAL :: ssum
    real time

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

    time = real(itau) / day_step + time_0
    dtvrs1j = dtvr/daysec
    rjour = real(int(itau*dtvrs1j))
    heure = (itau*dtvrs1j-rjour)*24.
    imjmp1 = iim*jjp1
    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/imjmp1)
    CALL scopy(ijp1llm, bern, 1, bernf, 1)
    CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE., 1)

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