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

Diff of /trunk/dyn3d/sortvarc.f

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

trunk/libf/dyn3d/sortvarc.f90 revision 23 by guez, Mon Dec 14 15:25:16 2009 UTC trunk/dyn3d/sortvarc.f revision 107 by guez, Thu Sep 11 15:09:15 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    real, save:: ang, etot, ptot, ztot, stot, rmsdpdt, rmsv
6    
7    !   Auteur:    P. Le Van  contains
   !   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 temps, ONLY : day_ini  
   USE ener, ONLY : ang, ang0, etot, etot0, ptot, ptot0, rmsdpdt, rmsv, &  
        stot, stot0, ztot, ztot0  
8    
9    IMPLICIT NONE    SUBROUTINE sortvarc(ucov, teta, ps, masse, pk, phis, vorpot, phi, &
10           bern, dp, resetvarc)
11    
12    !   Arguments:      ! From dyn3d/sortvarc.F, version 1.1.1.1 2004/05/19 12:53:07
13        ! Author: P. Le Van
14        ! Objet : sortie des variables de contrôle
15    
16        USE comconst, ONLY: daysec, g, omeg, rad
17        USE comgeom, ONLY: aire_2d, cu_2d, rlatu
18        USE dimens_m, ONLY: iim, jjm, llm
19        USE ener, ONLY: ang0, etot0, ptot0, stot0, ztot0
20        use filtreg_m, only: filtreg
21        use massbarxy_m, only: massbarxy
22        USE paramet_m, ONLY: iip1, ip1jm, jjp1
23    
24        REAL, INTENT(IN):: ucov(iim + 1, jjm + 1, llm)
25        REAL, INTENT(IN):: teta(iim + 1, jjm + 1, llm)
26        REAL, INTENT(IN):: ps(iim + 1, jjm + 1)
27        REAL, INTENT(IN):: masse(iim + 1, jjm + 1, llm)
28        REAL, INTENT(IN):: pk(iim + 1, jjm + 1, llm)
29        REAL, INTENT(IN):: phis(iim + 1, jjm + 1)
30        REAL, INTENT(IN):: vorpot(ip1jm, llm)
31        REAL, intent(in):: phi(iim + 1, jjm + 1, llm)
32        real, intent(in):: bern(iim + 1, jjm + 1, llm)
33        REAL, intent(in):: dp(iim + 1, jjm + 1)
34        logical, intent(in):: resetvarc
35    
36        ! Local:
37        REAL vor(ip1jm), bernf(iim + 1, jjm + 1, llm), ztotl(llm)
38        REAL etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(iim + 1, jjm + 1)
39        REAL cosphi(2:jjm)
40        REAL radsg, radomeg
41        REAL massebxy(ip1jm, llm)
42        INTEGER j, l, ij
43        REAL ssum
44    
45        !-----------------------------------------------------------------------
46    
47        PRINT *, "Call sequence information: sortvarc"
48    
49        CALL massbarxy(masse, massebxy)
50    
51        ! Calcul  de  rmsdpdt
52        ge = dp*dp
53        rmsdpdt = sum(ge) - sum(ge(1, :))
54        rmsdpdt = daysec*1.E-2*sqrt(rmsdpdt / (iim * jjp1))
55        bernf = bern
56        CALL filtreg(bernf, direct = .false., intensive = .false.)
57    
58        ! Calcul du moment  angulaire
59        radsg = rad/g
60        radomeg = rad*omeg
61        cosphi = cos(rlatu(2:jjm))
62    
63        ! Calcul  de l'energie, de l'enstrophie, de l'entropie et de rmsv
64    
65        DO l = 1, llm
66           DO ij = 1, ip1jm
67              vor(ij) = vorpot(ij, l)*vorpot(ij, l)*massebxy(ij, l)
68           END DO
69           ztotl(l) = (ssum(ip1jm, vor, 1)-ssum(jjm, vor, iip1))
70    
71           ge = masse(:, :, l) * (phis + teta(:, :, l) * pk(:, :, l) &
72                + bernf(:, :, l) - phi(:, :, l))
73           etotl(l) = sum(ge) - sum(ge(1, :))
74    
75           ge = masse(:, :, l)*teta(:, :, l)
76           stotl(l) = sum(ge) - sum(ge(1, :))
77    
78           ge = masse(:, :, l) * max(bernf(:, :, l) - phi(:, :, l), 0.)
79           rmsvl(l) = 2.*(sum(ge)-sum(ge(1, :)))
80    
81           forall (j = 2:jjm) ge(:, j) = (ucov(:, j, l) / cu_2d(:, j) &
82                + radomeg * cosphi(j)) * masse(:, j, l) * cosphi(j)
83           angl(l) = radsg * (sum(ge(:, 2:jjm)) - sum(ge(1, 2:jjm)))
84        END DO
85    
86        ge = ps * aire_2d
87        ptot = sum(ge) - sum(ge(1, :))
88        etot = sum(etotl)
89        ztot = sum(ztotl)
90        stot = sum(stotl)
91        rmsv = sum(rmsvl)
92        ang = sum(angl)
93    
94        IF (resetvarc .or. ptot0 == 0.) then
95           print *, 'sortvarc: recomputed initial values.'
96           etot0 = etot
97           ptot0 = ptot
98           ztot0 = ztot
99           stot0 = stot
100           ang0  = ang
101           PRINT *, 'ptot0 = ', ptot0
102           PRINT *, 'etot0 = ', etot0
103           PRINT *, 'ztot0 = ', ztot0
104           PRINT *, 'stot0 = ', stot0
105           PRINT *, 'ang0 = ', ang0
106        END IF
107    
108        IF (.not. resetvarc) then
109           etot = etot/etot0
110           rmsv = sqrt(rmsv/ptot)
111           ptot = ptot/ptot0
112           ztot = ztot/ztot0
113           stot = stot/stot0
114           ang = ang/ang0
115        end IF
116    
117    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/)  
118    
119  END SUBROUTINE sortvarc  end module sortvarc_m
Legend:
Removed from v.23  
changed lines
  Added in v.107
  ViewVC Help
Powered by ViewVC 1.1.21