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

Diff of /trunk/dyn3d/sortvarc.f

Parent Directory | 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 256 by guez,
Tue Mar  6 14:29:20 2018 UTC
 Line 1
- SUBROUTINE sortvarc(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp, &
+ module sortvarc_m
-      time)
+   IMPLICIT NONE
-   ! From dyn3d/sortvarc.F,v 1.1.1.1 2004/05/19 12:53:07
+   real, save:: ang, etot, ptot, ztot, stot, rmsdpdt, rmsv
-   !   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
-   IMPLICIT NONE
+   SUBROUTINE sortvarc(ucov, teta, ps, masse, pk, phis, vorpot, phi, bern, dp, &
+        resetvarc)
-   !   Arguments:
+     ! 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\^ole
+     USE comconst, ONLY: daysec, g, omeg, rad
+     USE comgeom, ONLY: aire_2d, cu_2d
+     USE dimens_m, ONLY: iim, jjm, llm
+     use dynetat0_m, ONLY: rlatu
+     USE ener, ONLY: ang0, etot0, ptot0, stot0, ztot0
+     use filtreg_scal_m, only: filtreg_scal
+     use massbarxy_m, only: massbarxy
+     USE paramet_m, ONLY: jjp1
+     REAL, INTENT(IN):: ucov(iim + 1, jjm + 1, llm)
+     REAL, INTENT(IN):: teta(iim + 1, jjm + 1, llm)
+     REAL, INTENT(IN):: ps(iim + 1, jjm + 1)
+     REAL, INTENT(IN):: masse(iim + 1, jjm + 1, llm)
+     REAL, INTENT(IN):: pk(iim + 1, jjm + 1, llm)
+     REAL, INTENT(IN):: phis(iim + 1, jjm + 1)
+     REAL, INTENT(IN):: vorpot(:, :, :) ! (iim + 1, jjm, llm)
+     REAL, intent(in):: phi(iim + 1, jjm + 1, llm)
+     real, intent(in):: bern(iim + 1, jjm + 1, llm)
+     REAL, intent(in):: dp(iim + 1, jjm + 1)
+     logical, intent(in):: resetvarc
+     ! Local:
+     REAL bernf(iim + 1, jjm + 1, llm)
+     REAL etotl(llm), stotl(llm), rmsvl(llm), angl(llm), ge(iim + 1, jjm + 1)
+     REAL cosphi(2:jjm)
+     REAL radsg, radomeg
+     REAL massebxy(iim + 1, jjm, llm)
+     INTEGER j, l
+     !-----------------------------------------------------------------------
+     PRINT *, "Call sequence information: sortvarc"
+     CALL massbarxy(masse, massebxy)
+     ! Calcul  de  rmsdpdt
+     ge = dp * dp
+     rmsdpdt = sum(ge(:iim, :))
+     rmsdpdt = daysec * 1.E-2 * sqrt(rmsdpdt / (iim * jjp1))
+     bernf = bern
+     CALL filtreg_scal(bernf, direct = .false., intensive = .false.)
+     ! Calcul du moment  angulaire
+     radsg = rad/g
+     radomeg = rad * omeg
+     cosphi = cos(rlatu(2:jjm))
+     ! Calcul  de l'energie, de l'enstrophie, de l'entropie et de rmsv
+     DO l = 1, llm
+        ge = masse(:, :, l) * (phis + teta(:, :, l) * pk(:, :, l) &
+             + bernf(:, :, l) - phi(:, :, l))
+        etotl(l) = sum(ge(:iim, :))
+        ge = masse(:, :, l) * teta(:, :, l)
+        stotl(l) = sum(ge(:iim, :))
+        ge = masse(:, :, l) * max(bernf(:, :, l) - phi(:, :, l), 0.)
+        rmsvl(l) = 2. * sum(ge(:iim, :))
+        forall (j = 2:jjm) ge(:, j) = (ucov(:, j, l) / cu_2d(:, j) &
+             + radomeg * cosphi(j)) * masse(:, j, l) * cosphi(j)
+        angl(l) = radsg * sum(ge(:iim, 2:jjm))
+     END DO
+     ge = ps * aire_2d
+     ptot = sum(ge(:iim, :))
+     etot = sum(etotl)
+     ztot = sum(vorpot(:iim, :, :)**2 * massebxy(:iim, :, :))
+     stot = sum(stotl)
+     rmsv = sum(rmsvl)
+     ang = sum(angl)
+     IF (resetvarc .or. ptot0 == 0.) then
+        print *, 'sortvarc: recomputed initial values.'
+        etot0 = etot
+        ptot0 = ptot
+        ztot0 = ztot
+        stot0 = stot
+        ang0  = ang
+        PRINT *, 'ptot0 = ', ptot0
+        PRINT *, 'etot0 = ', etot0
+        PRINT *, 'ztot0 = ', ztot0
+        PRINT *, 'stot0 = ', stot0
+        PRINT *, 'ang0 = ', ang0
+     END IF
+     IF (.not. resetvarc) then
+        etot = etot/etot0
+        rmsv = sqrt(rmsv/ptot)
+        ptot = ptot/ptot0
+        ztot = ztot/ztot0
+        stot = stot/stot0
+        ang = ang/ang0
+     end IF
-   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
-FORMAT (4X,'pas',I7,5X,'jour',F5.0,'heure',F5.1,4X,'date',F10.5)
-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

 Legend:



Removed from v.23
 


changed lines


 
Added in v.256
 Legend:



Removed from v.23
 


changed lines


 
Added in v.256
-Removed from v.23
+Added in v.256

	ViewVC Help
Powered by ViewVC 1.1.21