*=*=*=*= testdyn.html =*=*=*=*
PROGRAM testdyn

PROGRAM testdyn


      PROGRAM testdyn
      IMPLICIT NONE

c=======================================================================
c
c   Auteur:  P. Le Van/ L.Fairhead/F.Hourdin
c   -------
c
c   Objet:
c   ------
c
c   GCM LMD nouvelle grille
c
c=======================================================================

c   ... modification de l'integration de q ( 26/04/94 ) ....

c-----------------------------------------------------------------------
c   Declarations:
c   -------------

#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comdissip.h"
#include "comvert.h"
#include "comgeom.h"
#include "logic.h"
#include "temps.h"
#include "control.h"
#include "ener.h"
#include "description.h"

      INTEGER*4  iday ! jour julien
      REAL       time ! Heure de la journee en fraction d'1 jour
      REAL zdtvr
      INTEGER nbetatmoy, nbetatdem,nbetat
      INTEGER ierr, aslun, cllun

c   variables dynamiques
      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
      REAL h(ip1jmp1,llm)                    ! temperature potentielle
      REAL pext(ip1jmp1)                     ! pression extensive
      REAL pks(ip1jmp1),pksf(ip1jmp1)        ! exner (f pour filtre)
      REAL phis(ip1jmp1)                     ! geopotentiel au sol
      REAL phi(ip1jmp1,llm)                  ! geopotentiel
      REAL w(ip1jmp1,llm)                    ! vitesse verticale

      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
c z.x.li      REAL qm1(ip1jmp1,llm,nqmx)
      REAL dq(ip1jmp1,llm,nqmx)

c variables dynamiques intermediaire pour le transport
      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse

c   variables dynamiques au pas -1
      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
      REAL hm1(ip1jmp1,llm),pextm1(ip1jmp1)
c z.x.li      REAL qm1(ip1jmp1,llm,nqmx)

c   tendances dynamiques
      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
      REAL dh(ip1jmp1,llm),dp(ip1jmp1)

c   tendances de la dissipation
      REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
      REAL dhdis(ip1jmp1,llm)

c   tendances physiques
      REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
      REAL dhfi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1)

c   rappel Newtonnien
      REAL teq(ip1jmp1,llm)  ! temperature de rappel
      REAL cterad            ! constante de temps

c   variables pour le fichier histoire
      REAL dtav      ! intervalle de temps elementaire

      INTEGER taphistd,taprstar,taphmoy,tapphys

      INTEGER itau,itaufinp1,iav,ij,l,idum

      EXTERNAL caldyn
      EXTERNAL dissip,geopot,iniconst,inifilr,ecriba
      EXTERNAL integrd,lectba,SCOPY
      EXTERNAL iniav
      EXTERNAL inigeom
      EXTERNAL exner,addit

      REAL time_0 , finvpold(ip1jmp1),xx,ran1

c-----------------------------------------------------------------------
c   Initialisations:
c   ----------------

c quelques constantes pour la dissipation
      tetavel=5000.
      tetatemp=5000.
      niterdis=2
      lstardis=.false.
      grireg=.true.
      descript='Test DRS sur testdyn'

      rad=6400000.
      g=9.8
      r=8.314*1000./28.
      mugaz=28.
      kappa=.2857
      day_step=180
      daysec=86400.
      omeg=4.*asin(1.)/daysec


      CALL defrun(5)

c  on recalcule eventuellement le pas de temps
      IF(MOD(day_step,iperiod).NE.0)
     sSTOP'Il faut choisir un nb de pas par jour multiple de iperiod'
      zdtvr    = daysec/float(day_step)
      IF(dtvr.NE.zdtvr) THEN
         PRINT*,'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
      ENDIF

c  nombre d'etats dans les fichiers demarrage et histoire
      nbetatdem = nday / iecri
      nbetatmoy = nday / periodav + 1

      dtvr=zdtvr
c   constantes
      CALL iniconst
c   intialisation de la geometrie
      CALL inigeom
c   initialisation du filtre
      CALL inifilr


c-----------------------------------------------------------------------
c   initialisation de la temperature de rappel:
c   -------------------------------------------

c   cinitialisation de la temperature de rappel Newtonnien
      CALL inirappel(teq)
      cterad=dtvr/(30.*daysec)

      idum=-1
      xx=RAN1(idum)

c   pression extensive au sol
      do ij=1,ip1jmp1
         pext(ij)=100000.*aire(ij)
         phis(ij)=0.
      enddo
      CALL exner(ip1jmp1,pext,aire,pks,pksf)

c  intialisation du vent et de la temperature
      do l=1,llm
         do ij=1,ip1jmp1
            ucov(ij,l)=0.
            h(ij,l)=cpp*(250.
     .      +COS(rlatu((ij-1)/iip1+1))*(RAN1(idum)-.5))
     .      /(pks(ij)*s(l))
         enddo
         do ij=1,ip1jm
            vcov(ij,l)=0.
         enddo
      enddo
      call scopy(jjp1*llm,h,iip1,h(iip1,1),iip1)

c   intialisation de la dissipation horizontale
      CALL inidissip(lstardis,niterdis,tetavel,tetatemp)

c-----------------------------------------------------------------------
c   temps de depart et de fin:
c   --------------------------

      itau=0
      iday=day_ini+itau/day_step
      time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
      IF(time.GT.1.) THEN
         time=time-1.
         iday=iday+1
      ENDIF
      itaufin   = nday*day_step
      itaufinp1 = itaufin +1

      day_end=day_ini+nday
      PRINT 300, itau,itaufin,day_ini,day_end

      ecripar = .true.

      dtav=iperiod*dtvr/daysec

c-----------------------------------------------------------------------
c   Debut de l'integration temporelle:
c   ----------------------------------

      print*,'DT',dtvr
   1  CONTINUE
      CALL SCOPY( ijmllm,vcov,1,vcovm1,1 )
      CALL SCOPY( ijp1llm,ucov,1,ucovm1,1 )
      CALL SCOPY( ijp1llm,h,1,hm1,1 )
      CALL SCOPY( ip1jmp1,pext,1,pextm1,1 )
c z.x.li      CALL SCOPY( ijp1llm*nqmx,q,1,qm1,1 )
      forward = .true.
      leapf   = .false.
      dt      = dtvr

c   ...    P.Le Van .26/04/94  ....

      CALL SCOPY   ( ip1jmp1,pext,1,finvpold,1 )
      CALL filtreg ( finvpold ,jjp1, 1, -2,2, .TRUE., 1 )

   2  CONTINUE

c-----------------------------------------------------------------------

c   date:
c   -----


c   gestion des appels de la physique et des dissipations:
c   ------------------------------------------------------

      apphys = .false.
      statcl = .false.
      conser = .false.
      apdiss = .false.
      IF( MOD(itau   ,iconser) .eq. 0             ) conser = .true.
      IF( MOD(itau+1,idissip) .eq. 0             ) apdiss = .true.
      IF( MOD(itau,iphysiq).eq.0.AND.forward
     $                         .AND.    physic    ) apphys = .true.

c-----------------------------------------------------------------------
c   calcul des tendances dynamiques:
c   --------------------------------

      CALL geopot  (ip1jmp1, h     , pks   , phis    , phi          )
      CALL caldyn
     $ (itau,ucov,vcov,h,pext,pks,pksf,phis,
     $  phi,conser,du,dv,dh,dp,w, pbaru,pbarv,
     $  time+iday-day_ini)

c-----------------------------------------------------------------------
c   integrations dynamique:
c   -----------------------

      CALL integrd
     $ ( nqmx,vcovm1,ucovm1,hm1,pextm1,
c z.x.li     $ ( nqmx,vcovm1,ucovm1,hm1,qm1,pextm1,
     $   dv,du,dh,dq,dp,
     $   vcov,ucov,h,q,pext,phis,finvpold )


c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)

c-----------------------------------------------------------------------
c   ajout des tendances physiques:
c   ------------------------------
c    Ajout des tendances  a chaque  pas d'integration  ....

      IF(physic) THEN
         DO l=1,llm
            DO ij=1,ip1jmp1
               h(ij,l)=h(ij,l)-cterad*(h(ij,l)-teq(ij,l))
            ENDDO
         ENDDO
         call friction(ucov,vcov,iphysiq*dtvr)
      ENDIF

      CALL exner(ip1jmp1,pext,aire,pks,pksf)

c-----------------------------------------------------------------------
c   dissipation horizontal et verticales des petites echelles:
c   ----------------------------------------------------------

      IF(apdiss) THEN
         CALL dissip(vcov,ucov,h,dvdis,dudis,dhdis)
         CALL addit(ijp1llm,ucov,dudis,ucov)
         CALL addit(ijmllm,vcov,dvdis,vcov)
         CALL addit(ijp1llm,h,dhdis,h)
      END IF


c   ********************************************************************
c   ********************************************************************
c   .... fin de l'integration dynamique  et physique pour le pas itau ..
c   ********************************************************************
c   ********************************************************************

c   preparation du pas d'integration suivant  ......
c       ........................................................
c       ..............  schema matsuno + leapfrog  ..............
c       ........................................................

            IF(forward. OR. leapf) THEN
               itau= itau + 1
               iday=day_ini+itau/day_step
               time=FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
               IF(time.GT.1.) THEN
                  time=time-1.
                  iday=iday+1
               ENDIF
            ENDIF


            IF( itau. eq. itaufinp1 )    STOP

c-----------------------------------------------------------------------
c   ecriture du fichier histoire moyenne:
c   -------------------------------------

            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
               IF(itau.EQ.itaufin) THEN
                  iav=1
               ELSE
                  iav=0
               ENDIF
            ENDIF

c-----------------------------------------------------------------------
c   ecriture de la bande histoire:
c   ------------------------------

            IF( MOD(itau,iecri*day_step).eq.0) THEN
               nbetat = nbetatdem
c   ecriture des sorties
               call writeh(phis,ucov,vcov,h,pext,time)
            ENDIF
            IF(itau.EQ.itaufin) THEN
c    sauvegarde de l'etat initial a cet endroit
            ENDIF

c-----------------------------------------------------------------------
c   gestion de l'integration temporelle:
c   ------------------------------------

            IF( MOD(itau,iperiod).eq.0 )    THEN
                  GO TO 1
            ELSE IF ( MOD(itau-1,iperiod). eq. 0 ) THEN

                   IF( forward )  THEN
c      fin du pas forward et debut du pas backward

                      forward = .false.
                        leapf = .false.
                         GO TO 2

                   ELSE
c      fin du pas backward et debut du premier pas leapfrog

                        leapf =  .true.
                        dt  =  2.*dtvr
                        GO TO 2
                   END IF
            ELSE

c      ......   pas leapfrog  .....

                 leapf = .true.
                 dt  = 2.*dtvr
                 GO TO 2
            END IF



 300  FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x,  'c"est a dire du
     * jour'i7,3x'au jour'i7//)
          STOP
          END
c======================================================================= *=*=*=*= friction.html =*=*=*=*
SUBROUTINE friction

SUBROUTINE friction


      SUBROUTINE friction(ucov,vcov,pdt)
      IMPLICIT NONE

c=======================================================================
c
c
c   Objet:
c   ------
c
c  ***********
c    Friction
c  ***********
c
c=======================================================================

#include "dimensions.h"
#include "paramet.h"
#include "comgeom2.h"
#include "control.h"
#include "comconst.h"

      REAL pdt
      REAL modv(iip1,jjp1),zco,zsi
      REAL vpn,vps,upoln,upols,vpols,vpoln
      REAL u2(iip1,jjp1),v2(iip1,jjm)
      REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm )
      INTEGER  i,j
      REAL cfric
      parameter (cfric=1.e-6)


c   calcul des composantes au carre du vent naturel
      do j=1,jjp1
         do i=1,iip1
            u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j)
         enddo
      enddo
      do j=1,jjm
         do i=1,iip1
            v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j)
         enddo
      enddo

c   calcul du module de V en dehors des poles
      do j=2,jjm
         do i=2,iip1
            modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j)))
         enddo
         modv(1,j)=modv(iip1,j)
      enddo

c   les deux composantes du vent au pole sont obtenues comme
c   premiers modes de fourier de v pres du pole
      upoln=0.
      vpoln=0.
      upols=0.
      vpols=0.
      do i=2,iip1
         zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1))
         zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1))
         vpn=vcov(i,1,1)/cv(i,1)
         vps=vcov(i,jjm,1)/cv(i,jjm)
         upoln=upoln+zco*vpn
         vpoln=vpoln+zsi*vpn
         upols=upols+zco*vps
         vpols=vpols+zsi*vps
      enddo
      vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi
      vps=sqrt(upols*upols+vpols*vpols)/pi
      do i=1,iip1
         modv(i,1)=vpn
         modv(i,jjp1)=vps
      enddo

c   calcul du frottement au sol.
      do j=2,jjm
         do i=1,iim
            ucov(i,j,1)=ucov(i,j,1)
     s      -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1)
         enddo
         ucov(iip1,j,1)=ucov(1,j,1)
      enddo
      do j=1,jjm
         do i=1,iip1
            vcov(i,j,1)=vcov(i,j,1)
     s      -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1)
         enddo
      enddo

      RETURN
      END
*=*=*=*= writeh.html =*=*=*=*
subroutine writeh

subroutine writeh


      subroutine writeh(phis,ucov,vcov,h,pext,time)
      implicit none
#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comvert.h"
#include "comgeom2.h"
      REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),h(iip1,jjp1,llm)
      REAL pext(iip1,jjp1)
      REAL phis(iip1,jjp1)
      REAL time

      INTEGER i,j,l

      INTEGER irec,isor,nout
      logical first
      save first,irec,isor,nout
      data first/.true./
      data nout/88/

c   variables meteo:
c   ----------------

      REAL u(iip1,jjp1,llm),v(iip1,jjp1,llm),t(iip1,jjp1,llm)
      REAL pks(iip1,jjp1),pksf(iip1,jjp1)


      if(first) then
         OPEN (nout+1,FILE='hist.dat',
     .      FORM='UNFORMATTED',
     &      ACCESS='DIRECT',RECL=4*(iim+1)*(jjm+1))
          first=.false.
          irec=1
          isor=0
      endif

      CALL exner(ip1jmp1,pext,aire,pks,pksf)
      do l=1,llm
          do j=1,jjp1
             do i=1,iip1
                t(i,j,l)=s(l)*h(i,j,l)*pks(i,j)/cpp
             enddo
          enddo
       enddo
       call covsnat(ucov,vcov,u,v)
       write(nout+1,rec=irec) ((pext(i,j)/aire(i,j),i=1,iip1)
     s,j=1,jjp1)
       irec=irec+1
       do l=1,llm
         write(nout+1,rec=irec) ((u(i,j,l),i=1,iip1),j=1,jjp1)
         irec=irec+1
       enddo
       do l=1,llm
         write(nout+1,rec=irec) ((v(i,j,l),i=1,iip1),j=1,jjp1)
         irec=irec+1
       enddo
       do l=1,llm
         write(nout+1,rec=irec) ((t(i,j,l),i=1,iip1),j=1,jjp1)
         irec=irec+1
       enddo
      isor=isor+1


c   WARNING! on reecrase le fichier .ctl a chaque ecriture
      open(nout,file='hist.ctl',form='formatted',status='unknown')
      write(nout,*) 'DSET hist.dat'

      write(nout,*) 'UNDEF ',1.0E30
      write(nout,*) 'FORMAT YREV'
      write(nout,*) 'TITLE ',' Test '
      write(nout,*) 'XDEF ',iim+1,' LEVELS '
      write(nout,'(7f8.2)')  (rlonv(i)*180/pi,i=1,iim+1)
      write(nout,*) 'YDEF ',jjm+1,' LEVELS '
      write(nout,'(7f8.2)') (rlatu(jjm+2-i)*180/pi,i=1,jjm+1)
      write(nout,'(a6,i4,a8)') 'ZDEF ',llm,' LEVELS '
      write(nout,'(5f10.2)') (1000.*s(i)**(1./kappa),i=1,llm)
      write(nout,*) 'TDEF ',isor,' LINEAR 02JAN1987 1MO '
      write(nout,*) 'VARS 4'
      write(nout,1000) 'ps       ',0,  99,'Pression au sol'
      write(nout,1000) 'u        ',llm,  99,'vent zonal'
      write(nout,1000) 'v        ',llm,  99,'vent meridien'
      write(nout,1000) 't        ',llm,  99,'temperature'
      write(nout,*) 'ENDVARS'
      close(nout)

1000  format(a9,i4,i3,x,a39)

      END
*=*=*=*= covsnat.html =*=*=*=*
SUBROUTINE covsnat

SUBROUTINE covsnat


      SUBROUTINE covsnat(ucov,vcov,u,v)
      IMPLICIT NONE

c-----------------------------------------------------------------------
c   transformation du vent sur la grille scalaire pour les sorties
c-----------------------------------------------------------------------

c   declarations:
c   -------------

#include "dimensions.h"
#include "paramet.h"
#include "comgeom2.h"
#include "comconst.h"

c   arguments:
c   ----------

      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm)
      REAL u(iip1,jjp1,llm),v(iip1,jjp1,llm)

c   local:
c   ------

      INTEGER npresmx
      PARAMETER (npresmx=llm)

      INTEGER i,j,l
      REAL z1(iip1),zcos(iip1),zsin(iip1)
      REAL zunord,zusud,zvnord,zvsud


      EXTERNAL writestd,interpol,geopot
      EXTERNAL SSUM
      REAL SSUM

c-----------------------------------------------------------------------
c   vents:
c   ------

c   47. champs de vents aux pole nord
c   ------------------------------
c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]


      DO l=1,llm

            z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*vcov(1,1,l)/cv(1,1)
            DO i=2,iim
               z1(i)=(rlonu(i)-rlonu(i-1))*vcov(i,1,l)/cv(i,1)
            ENDDO

            DO i=1,iim
               zcos(i)=COS(rlonv(i))*z1(i)
               zsin(i)=SIN(rlonv(i))*z1(i)
            ENDDO
            zunord=SSUM(iim,zcos,1)/pi
            zvnord=SSUM(iim,zsin,1)/pi



c   48. champs de vents aux pole sud:
c   ---------------------------------
c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]


            z1(1)=(rlonu(1)-rlonu(iim)+2.*pi)*vcov(1,jjm,l)/cv(1,jjm)
            DO i=2,iim
               z1(i)=(rlonu(i)-rlonu(i-1))*vcov(i,jjm,l)/cv(i,jjm)
            ENDDO

            DO i=1,iim
               zcos(i)=COS(rlonv(i))*z1(i)
               zsin(i)=SIN(rlonv(i))*z1(i)
            ENDDO
            zusud=SSUM(iim,zcos,1)/pi
            zvsud=SSUM(iim,zsin,1)/pi

            DO j=2,jjm
               DO i=2,iim
                  u(i,j,l)=
     $            0.5*(ucov(i,j,l)/cu(i,j)+ucov(i-1,j,l)/cu(i-1,j))
               ENDDO
               u(1,j,l)=
     s         0.5*(ucov(1,j,l)/cu(1,j)+ucov(iim,j,l)/cu(iim,j))
               u(iip1,j,l)=u(1,j,l)
            ENDDO

            DO i=1,iip1
               u(i,1,l)   = zunord*SIN(rlonv(i))-zvnord*COS(rlonv(i))
               u(i,jjp1,l)=-zusud*SIN(rlonv(i))+zvsud*COS(rlonv(i))
               v(i,1,l)   = zunord*COS(rlonv(i))+zvnord*SIN(rlonv(i))
               v(i,jjp1,l)= zusud*COS(rlonv(i))+zvsud*SIN(rlonv(i))
            ENDDO

            DO j=2,jjm
               DO i=1,iip1
                  v(i,j,l)=
     $            0.5*(vcov(i,j,l)/cv(i,j)+vcov(i,j-1,l)/cv(i,j-1))
               ENDDO
            ENDDO

      enddo

      RETURN
      END