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

PROGRAM testdyn


      PROGRAM testdyn
      IMPLICIT NONE

c=======================================================================
c
c   Auteur:  P. Le Van/ L.Fairhead/F.Hourdin
c   -------
c   Modif special traceur F.Forget 05/94
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 "drsdef.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 q(ip1jmp1,llm,nqmx)               ! champs advectes
      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

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),dq(ip1jmp1,llm,nqmx),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 iadv(nqmx) ! indice schema de transport pour le traceur iq

      INTEGER taphistd,taprstar,taphmoy,tapphys

      INTEGER itau,itaufinp1,iav,ij,l

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

      REAL time_0 , finvpold(ip1jmp1)

      LOGICAL startdrs

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

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

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

      CALL lectba(startdrs,nqmx,vcov,ucov,h,q,pext,phis,time_0)
      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
      CALL iniconst
      CALL inigeom

      IF(grireg) CALL inifilr
      CALL inidissip(lstardis,niterdis,tetavel,tetatemp)

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

c  numero de stockage pour les fichiers de redemarrage:
      taphistd=10
      tapphys=12
      taprstar=15
      taphmoy=20

c  ouverture DRS des fichiers de stockage
      IF(startdrs) THEN
         ierr = aslun(taphistd,'histoire.dic',
     .             taphistd+1,'histoire.dat',IDRS_CREATE)
      ELSE
         PRINT*,'Ouverture binaire',taphistd
         OPEN(taphistd,file='histoire',form='unformatted',
     .   status='new',iostat=ierr)
      ENDIF
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier histoire (rdem)'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
      IF(startdrs) THEN
         ierr = aslun(taprstar,'restart.dic',
     .             taprstar+1,'restart.dat',IDRS_CREATE)
      ELSE
         OPEN(taprstar,file='restart',form='unformatted',
     .   status='new',iostat=ierr)
      ENDIF
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier restart'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
      ierr = aslun(taphmoy,'histmoy.dic',
     .             taphmoy+1,'histmoy.dat',IDRS_CREATE)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier restart'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif

c     ierr = aslun(tapphys,'histphy.dic',
c    .             tapphys+1,'histphy.dat',IDRS_CREATE)
c     if (ierr.ne.0) then
c       write(6,*)' Pb d''ouverture du fichier physique'
c       write(6,*)' ierr = ', ierr
c       call exit(1)
c     endif

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

      CALL iniwrite(taphistd,startdrs,day_ini,phis)
      CALL iniwrite(tapphys,startdrs,day_ini,phis)
      CALL iniwrite(taprstar,startdrs,day_end,phis)

      ecripar = .true.

      dtav=iperiod*dtvr/daysec
      CALL iniav(taphmoy,day_ini,0.,periodav,phis)

c-----------------------------------------------------------------------
c   initialisation de la temperature de rappel:
c   -------------------------------------------
      IF(physic) THEN
c   cinitialisation de la temperature de rappel Newtonnien
          CALL inirappel(teq)
c   constante de rappel: dtvr/(30 jours)
          cterad=dtvr/(30.*daysec)
      ENDIF

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

   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,.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( purmats ) THEN
         IF( MOD(itau,iconser) .eq.0.AND.  forward    ) conser = .true.
         IF( MOD(itau,idissip ).eq.0.AND..NOT.forward ) apdiss = .true.
         IF( MOD(itau,iphysiq ).eq.0.AND.  forward
     $                             .AND.    physic    ) apphys = .true.
      ELSE
         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.
      END IF

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   calcul des tendances advection des traceurs (dont l'humidite)
c   -------------------------------------------------------------

      CALL traceur(nqmx,iadv,q,w, pbaru, pbarv, dq )

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  ......

      IF ( .not.purmats ) THEN
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
               CALL writeav(nqmx,dtav,time+iday-day_ini
     .         ,ucov,vcov,h,q,pext,iav)
            ENDIF

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

            IF( MOD(itau,iecri*day_step).eq.0) THEN
               nbetat = nbetatdem
               call writedem(taphistd,nqmx,startdrs,time+iday-day_ini,
     .                        vcov,ucov,h,q,pext,
     .                        phis,nbetat)
            ENDIF
            IF(itau.EQ.itaufin) THEN
               call writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q,
     .         pext,phis, 1)
               CLOSE(99)
c              OPEN(99,file='champ_fin',form='unformatted',
c    .         status='unknown')
c              WRITE(99) ucov,vcov,h,pext,phis
c              CLOSE(99)
            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

      ELSE

c       ........................................................
c       ..............       schema  matsuno        ...............
c       ........................................................
            IF( forward )  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
               forward =  .false.
               IF( itau. eq. itaufinp1 )    STOP
               GO TO 2
            ELSE
               IF(MOD(itau,iecri*day_step).EQ.0) THEN
                  nbetat = nbetatdem
                  call writedem(taphistd,nqmx,startdrs,
     .            time+iday-day_ini,
     .                           vcov,ucov,h,q,pext,
     .                           phis,nbetat)

               ENDIF
               IF(itau.EQ.itaufin)
     .         call writedem(taprstar,nqmx,startdrs,0.,vcov,ucov,h,q
     .         ,pext,phis,1)
               forward = .true.
               GO TO  1
            ENDIF

      END IF
      ierr = cllun(taphistd)
      ierr = cllun(taprstar)
      ierr = cllun(taphmoy)


 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