source: LMDZ5/branches/IPSLCM5A2.1/libf/dyn3d_common/sortvarc.F @ 3183

Last change on this file since 3183 was 2603, checked in by Ehouarn Millour, 8 years ago

Cleanup in the dynamics: turn logic.h into module logic_mod.F90
EM

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.5 KB
Line 
1!
2! $Id: sortvarc.F 2603 2016-07-25 09:31:56Z fairhead $
3!
4      SUBROUTINE sortvarc
5     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
6     $ vcov )
7
8      USE control_mod, ONLY: resetvarc
9      USE comconst_mod, ONLY: dtvr, daysec, g, rad, omeg
10      USE logic_mod, ONLY: read_start
11     
12      IMPLICIT NONE
13
14
15c=======================================================================
16c
17c   Auteur:    P. Le Van
18c   -------
19c
20c   Objet:
21c   ------
22c
23c   sortie des variables de controle
24c
25c=======================================================================
26c-----------------------------------------------------------------------
27c   Declarations:
28c   -------------
29
30      INCLUDE "dimensions.h"
31      INCLUDE "paramet.h"
32      INCLUDE "comgeom.h"
33      INCLUDE "ener.h"
34      INCLUDE "iniprint.h"
35
36c   Arguments:
37c   ----------
38
39      INTEGER,INTENT(IN) :: itau
40      REAL,INTENT(IN) :: ucov(ip1jmp1,llm)
41      REAL,INTENT(IN) :: teta(ip1jmp1,llm)
42      REAL,INTENT(IN) :: masse(ip1jmp1,llm)
43      REAL,INTENT(IN) :: vcov(ip1jm,llm)
44      REAL,INTENT(IN) :: ps(ip1jmp1)
45      REAL,INTENT(IN) :: phis(ip1jmp1)
46      REAL,INTENT(IN) :: vorpot(ip1jm,llm)
47      REAL,INTENT(IN) :: phi(ip1jmp1,llm)
48      REAL,INTENT(IN) :: bern(ip1jmp1,llm)
49      REAL,INTENT(IN) :: dp(ip1jmp1)
50      REAL,INTENT(IN) :: time
51      REAL,INTENT(IN) :: pk(ip1jmp1,llm)
52
53c   Local:
54c   ------
55
56      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
57      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
58      REAL cosphi(ip1jm),omegcosp(ip1jm)
59      REAL dtvrs1j,rjour,heure,radsg,radomeg
60      REAL massebxy(ip1jm,llm)
61      INTEGER  l, ij, imjmp1
62
63      REAL       SSUM
64      LOGICAL,SAVE :: firstcal=.true.
65      CHARACTER(LEN=*),PARAMETER :: modname="sortvarc"
66
67c-----------------------------------------------------------------------
68! Ehouarn: when no initialization fields from file, resetvarc should be
69!          set to false
70       if (firstcal) then
71         if (.not.read_start) then
72           resetvarc=.true.
73         endif
74       endif
75
76       dtvrs1j   = dtvr/daysec
77       rjour     = REAL( INT( itau * dtvrs1j ))
78       heure     = ( itau*dtvrs1j-rjour ) * 24.
79       imjmp1    = iim * jjp1
80       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
81c
82       CALL massbarxy ( masse, massebxy )
83
84c   .....  Calcul  de  rmsdpdt  .....
85
86       ge(:)=dp(:)*dp(:)
87
88       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
89c
90       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1)
91
92       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
93       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
94
95c   .....  Calcul du moment  angulaire   .....
96
97       radsg    = rad /g
98       radomeg  = rad * omeg
99c
100       DO ij=iip2,ip1jm
101          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
102          omegcosp(ij) = radomeg   * cosphi(ij)
103       ENDDO
104
105c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
106
107       DO l=1,llm
108          DO ij = 1,ip1jm
109             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
110          ENDDO
111          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
112
113          DO ij = 1,ip1jmp1
114             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
115     s        bernf(ij,l)-phi(ij,l))
116          ENDDO
117          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
118
119          DO   ij   = 1, ip1jmp1
120             ge(ij) = masse(ij,l)*teta(ij,l)
121          ENDDO
122          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
123
124          DO ij=1,ip1jmp1
125             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
126          ENDDO
127          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
128
129          DO ij =iip2,ip1jm
130             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
131     *               cosphi(ij)
132          ENDDO
133          angl(l) = rad *
134     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
135      ENDDO
136
137          DO ij=1,ip1jmp1
138            ge(ij)= ps(ij)*aire(ij)
139          ENDDO
140      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
141      etot  = SSUM(     llm, etotl, 1 )
142      ztot  = SSUM(     llm, ztotl, 1 )
143      stot  = SSUM(     llm, stotl, 1 )
144      rmsv  = SSUM(     llm, rmsvl, 1 )
145      ang   = SSUM(     llm,  angl, 1 )
146
147      IF (firstcal.and.resetvarc) then
148         WRITE(lunout,3500) itau, rjour, heure, time
149         WRITE(lunout,*) trim(modname),
150     &     ' WARNING!!! Recomputing initial values of : '
151         WRITE(lunout,*) 'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
152         WRITE(lunout,*) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
153         etot0 = etot
154         ptot0 = ptot
155         ztot0 = ztot
156         stot0 = stot
157         ang0  = ang
158      END IF
159
160      ! compute relative changes in etot,... (except if 'reference' values
161      ! are zero, which can happen when using iniacademic)
162      if (etot0.ne.0) then
163        etot= etot/etot0
164      else
165        etot=1.
166      endif
167      rmsv= SQRT(rmsv/ptot)
168      if (ptot0.ne.0) then
169        ptot= ptot/ptot0
170      else
171        ptot=1.
172      endif
173      if (ztot0.ne.0) then
174        ztot= ztot/ztot0
175      else
176        ztot=1.
177      endif
178      if (stot0.ne.0) then
179        stot= stot/stot0
180      else
181        stot=1.
182      endif
183      if (ang0.ne.0) then
184        ang = ang /ang0
185      else
186        ang=1.
187      endif
188
189      firstcal = .false.
190
191      WRITE(lunout,3500) itau, rjour, heure, time
192      WRITE(lunout,4000) ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
193
1943500   FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x
195     *   ,'date',f14.4,4x,10("*"))
1964000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
197     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB  '
198     .  ,f10.6,e13.6,5f10.3/
199     * )
200      END
201
Note: See TracBrowser for help on using the repository browser.