/[lmdze]/trunk/Sources/dyn3d/sortvarc.f
ViewVC logotype

Diff of /trunk/Sources/dyn3d/sortvarc.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/sortvarc.f90 revision 27 by guez, Thu Mar 25 14:29:07 2010 UTC trunk/dyn3d/sortvarc.f90 revision 78 by guez, Wed Feb 5 17:51:07 2014 UTC
# Line 1  Line 1 
1  SUBROUTINE sortvarc(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp, &  module sortvarc_m
      time)  
2    
3      IMPLICIT NONE
4    
5    ! From dyn3d/sortvarc.F,v 1.1.1.1 2004/05/19 12:53:07  contains
   
   !   Auteur:    P. Le Van  
   !   Objet:  
   !   sortie des variables de controle  
   
   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  
6    
7    IMPLICIT NONE    SUBROUTINE sortvarc(itau, ucov, teta, ps, masse, pk, phis, vorpot, phi, &
8           bern, dp, time_0)
9    
10    !   Arguments:      ! 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 comconst, ONLY: daysec, dtvr, g, omeg, rad
15        USE comgeom, ONLY: aire, cu, rlatu
16        USE conf_gcm_m, ONLY: day_step
17        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             stot, stot0, ztot, ztot0
21        use filtreg_m, only: filtreg
22        use massbarxy_m, only: massbarxy
23        USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1
24    
25        INTEGER, INTENT(IN):: itau
26        REAL, INTENT(IN):: ucov(ip1jmp1, llm)
27        REAL, INTENT(IN):: teta(ip1jmp1, llm)
28        REAL, INTENT(IN):: ps(ip1jmp1)
29        REAL, INTENT(IN):: masse(ip1jmp1, llm)
30        REAL, INTENT(IN):: pk(ip1jmp1, llm)
31        REAL, INTENT(IN):: phis(ip1jmp1)
32        REAL, INTENT(IN):: vorpot(ip1jm, llm)
33        REAL, intent(in):: phi(ip1jmp1, llm)
34        real, intent(in):: bern(ip1jmp1, llm)
35        REAL, intent(in):: dp(ip1jmp1)
36        REAL, INTENT (IN):: time_0
37    
38        ! Local:
39        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        REAL dtvrs1j, rjour, heure, radsg, radomeg
43        REAL massebxy(ip1jm, llm)
44        INTEGER l, ij
45        REAL ssum
46        real time
47    
48        !-----------------------------------------------------------------------
49    
50        PRINT *, "Call sequence information: sortvarc"
51    
52        time = real(itau) / day_step + time_0
53        dtvrs1j = dtvr/daysec
54        rjour = real(int(itau*dtvrs1j))
55        heure = (itau*dtvrs1j-rjour)*24.
56        IF (abs(heure-24.)<=0.0001) heure = 0.
57    
58        CALL massbarxy(masse, massebxy)
59    
60        ! Calcul  de  rmsdpdt
61        ge = dp*dp
62        rmsdpdt = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
63        rmsdpdt = daysec*1.E-2*sqrt(rmsdpdt / (iim * jjp1))
64        bernf = bern
65        CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)
66    
67        ! 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    
75        ! Calcul  de l'energie, de l'enstrophie, de l'entropie et de rmsv
76    
77        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    
83           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    
89           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    
94           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    
99           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    
106        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    
116        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    
127        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    
134        PRINT 3500, itau, int(day_ini + time), heure, time
135        PRINT 4000, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang
136    
137    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    
143    INTEGER, INTENT (IN) :: itau    END SUBROUTINE sortvarc
   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 :: time  
   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 :: rday, massebxy(ip1jm,llm)  
   INTEGER :: l, ij, imjmp1  
   
   REAL :: ssum  
   
   !-----------------------------------------------------------------------  
   
   dtvrs1j = dtvr/daysec  
   rjour = float(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)  
   
   rday = float(int(day_ini+time))  
   
   IF (ptot0==0.) THEN  
      PRINT 3500, itau, rday, heure, time  
      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, rday, heure, time  
   PRINT 4000, ptot, rmsdpdt, etot, ztot, stot, rmsv, ang  
   
   RETURN  
   
 3500 FORMAT (4X,'pas',I7,5X,'jour',F5.0,'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/)  
144    
145  END SUBROUTINE sortvarc  end module sortvarc_m
Legend:
Removed from v.27  
changed lines
  Added in v.78
  ViewVC Help
Powered by ViewVC 1.1.21