/[lmdze]/trunk/dyn3d/sortvarc0.f
ViewVC logotype

Diff of /trunk/dyn3d/sortvarc0.f

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

trunk/libf/dyn3d/sortvarc0.f90 revision 64 by guez, Wed Aug 29 14:47:17 2012 UTC trunk/dyn3d/sortvarc0.f90 revision 78 by guez, Wed Feb 5 17:51:07 2014 UTC
# Line 1  Line 1 
1  SUBROUTINE sortvarc0(ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp)  module sortvarc0_m
   
   ! From dyn3d/sortvarc0.F, v 1.1.1.1 2004/05/19 12:53:07  
   ! Auteur : P. Le Van  
   ! Objet : sortie des variables de contrôle  
   
   USE dimens_m, ONLY : iim, jjm, llm  
   USE paramet_m, ONLY : iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1  
   USE comconst, ONLY : daysec, g, omeg, rad  
   USE comgeom, ONLY : aire, cu, rlatu  
   USE ener, ONLY : ang0, etot0, ptot0, rmsdpdt, rmsv, stot0, ztot0  
   use filtreg_m, only: filtreg  
2    
3    IMPLICIT NONE    IMPLICIT NONE
4    
5    !   Arguments:  contains
6    
7      SUBROUTINE sortvarc0(ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp)
8    
9        ! From dyn3d/sortvarc0.F, version 1.1.1.1 2004/05/19 12:53:07
10        ! Author: P. Le Van
11        ! Objet : sortie des variables de contrôle
12    
13        USE comconst, ONLY: daysec, g, omeg, rad
14        USE comgeom, ONLY: aire, cu, rlatu
15        USE dimens_m, ONLY: iim, jjm, llm
16        USE ener, ONLY: ang0, etot0, ptot0, rmsdpdt, rmsv, stot0, ztot0
17        use filtreg_m, only: filtreg
18        use massbarxy_m, only: massbarxy
19        USE paramet_m, ONLY: iip1, iip2, ijp1llm, ip1jm, ip1jmp1, jjp1
20    
21        REAL, INTENT(IN):: ucov(ip1jmp1, llm)
22        REAL, INTENT(IN):: teta(ip1jmp1, llm)
23        REAL, INTENT(IN):: ps(ip1jmp1)
24        REAL, INTENT(IN):: masse(ip1jmp1, llm)
25        REAL, INTENT(IN):: pk(ip1jmp1, llm)
26        REAL, INTENT(IN):: phis(ip1jmp1)
27        REAL, INTENT(IN):: vorpot(ip1jm, llm)
28        REAL, intent(in):: phi(ip1jmp1, llm)
29        real, intent(in):: bern(ip1jmp1, llm)
30        REAL, intent(in):: dp(ip1jmp1)
31    
32        ! Local:
33        REAL:: vor(ip1jm), bernf(ip1jmp1, llm), ztotl(llm)
34        REAL:: etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(ip1jmp1)
35        REAL:: cosphi(ip1jm), omegcosp(ip1jm)
36        REAL radsg, radomeg
37        REAL massebxy(ip1jm, llm)
38        INTEGER l, ij
39        REAL ssum
40    
41        !-----------------------------------------------------------------------
42    
43        PRINT *, "Call sequence information: sortvarc0"
44    
45        CALL massbarxy(masse, massebxy)
46    
47        ! Calcul  de  rmsdpdt
48        ge = dp*dp
49        rmsdpdt = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
50        rmsdpdt = daysec*1.E-2*sqrt(rmsdpdt / (iim * jjp1))
51        bernf = bern
52        CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)
53    
54        ! Calcul du moment  angulaire
55        radsg = rad/g
56        radomeg = rad*omeg
57        DO ij = iip2, ip1jm
58           cosphi(ij) = cos(rlatu((ij-1)/iip1+1))
59           omegcosp(ij) = radomeg*cosphi(ij)
60        END DO
61    
62        ! Calcul  de l'energie, de l'enstrophie, de l'entropie et de rmsv
63    
64        DO l = 1, llm
65           DO ij = 1, ip1jm
66              vor(ij) = vorpot(ij, l)*vorpot(ij, l)*massebxy(ij, l)
67           END DO
68           ztotl(l) = (ssum(ip1jm, vor, 1)-ssum(jjm, vor, iip1))
69    
70           DO ij = 1, ip1jmp1
71              ge(ij) = masse(ij, l) * (phis(ij) + teta(ij, l) * pk(ij, l) &
72                   + bernf(ij, l)-phi(ij, l))
73           END DO
74           etotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
75    
76           DO ij = 1, ip1jmp1
77              ge(ij) = masse(ij, l)*teta(ij, l)
78           END DO
79           stotl(l) = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
80    
81           DO ij = 1, ip1jmp1
82              ge(ij) = masse(ij, l)*amax1(bernf(ij, l)-phi(ij, l), 0.)
83           END DO
84           rmsvl(l) = 2.*(ssum(ip1jmp1, ge, 1)-ssum(jjp1, ge, iip1))
85    
86           DO ij = iip2, ip1jm
87              ge(ij) = (ucov(ij, l)/cu(ij)+omegcosp(ij))*masse(ij, l)*cosphi(ij)
88           END DO
89           angl(l) = radsg * (ssum(ip1jm-iip1, ge(iip2), 1) &
90                - ssum(jjm-1, ge(iip2), iip1))
91        END DO
92    
93        DO ij = 1, ip1jmp1
94           ge(ij) = ps(ij)*aire(ij)
95        END DO
96        ptot0 = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)
97        etot0 = ssum(llm, etotl, 1)
98        ztot0 = ssum(llm, ztotl, 1)
99        stot0 = ssum(llm, stotl, 1)
100        rmsv = ssum(llm, rmsvl, 1)
101        ang0 = ssum(llm, angl, 1)
102    
103        PRINT *, 'ptot0 = ', ptot0
104        PRINT *, 'etot0 = ', etot0
105        PRINT *, 'ztot0 = ', ztot0
106        PRINT *, 'stot0 = ', stot0
107        PRINT *, 'ang0 = ', ang0
108    
109    REAL, INTENT (IN) :: ucov(ip1jmp1, llm)    END SUBROUTINE sortvarc0
   REAL :: teta(ip1jmp1, llm), masse(ip1jmp1, llm)  
   REAL, INTENT (IN) :: ps(ip1jmp1)  
   REAL, INTENT (IN) :: phis(ip1jmp1)  
   REAL :: vorpot(ip1jm, llm)  
   REAL :: phi(ip1jmp1, llm), bern(ip1jmp1, llm)  
   REAL :: dp(ip1jmp1)  
   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 radomeg  
   REAL massebxy(ip1jm, llm)  
   INTEGER l, ij  
   
   REAL :: ssum  
   
   !-----------------------------------------------------------------------  
   
   PRINT *, 'Call sequence information: sortvarc0'  
   
   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))  
   CALL scopy(ijp1llm, bern, 1, bernf, 1)  
   CALL filtreg(bernf, jjp1, llm, -2, 2, .TRUE.)  
   
   !  Calcul du moment  angulaire  
   
   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) = rad / g &  
           * (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  
   ptot0 = ssum(ip1jmp1, ge, 1) - ssum(jjp1, ge, iip1)  
   etot0 = ssum(llm, etotl, 1)  
   ztot0 = ssum(llm, ztotl, 1)  
   stot0 = ssum(llm, stotl, 1)  
   rmsv = ssum(llm, rmsvl, 1)  
   ang0 = ssum(llm, angl, 1)  
   
   PRINT *, 'ptot0 = ', ptot0  
   PRINT *, 'etot0 = ', etot0  
   PRINT *, 'ztot0 = ', ztot0  
   PRINT *, 'stot0 = ', stot0  
   PRINT *, 'ang0 = ', ang0  
110    
111  END SUBROUTINE sortvarc0  end module sortvarc0_m
Legend:
Removed from v.64  
changed lines
  Added in v.78
  ViewVC Help
Powered by ViewVC 1.1.21