*=*=*=*= initestdyn.html =*=*=*=*
PROGRAM initestdyn

PROGRAM initestdyn


      PROGRAM initestdyn
      IMPLICIT NONE

c=======================================================================
c
c   creation d'un etat initial
c
c=======================================================================
c
c-----------------------------------------------------------------------
c   declarations:
c   -------------

#include "dimensions.h"
#include "paramet.h"
#include "comconst.h"
#include "comvert.h"
#include "comgeom2.h"
#include "control.h"
#include "logic.h"
#include "drsdef.h"
#include "ener.h"


      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm),u(iip1,jjp1,llm)
      REAL um(jjp1,llm)
      REAL h(iip1,jjp1,llm),pext(iip1,jjp1)
      REAL pks(iip1,jjp1),pksf(iip1,jjp1)
      REAL phis(iip1,jjp1)
      REAL teq(iip1,jjp1,llm)
      REAL w(iip1,jjp1,llm+1)

      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)

      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
      REAL dh(ip1jmp1,llm),dp(ip1jmp1)

      REAL q(iip1,jjp1,llm,nqmx)
      INTEGER iq

c
      INTEGER i,j,l,itau,ig,idum
      INTEGER*4 day0
      INTEGER unit
      REAL p(iip1,jjp1),phis0,zz,fact
      REAL t(iip1,jjp1,llm)
      REAL phi(iip1,jjp1,llm)
      REAL xx
      REAL daydeb

      logical startdrs

      EXTERNAL RAN1
      REAL RAN1
      EXTERNAL iniconst,geopot,inigeom,inifis
      INTEGER aslun, cllun
      INTEGER ierr, nbetat
c
c-----------------------------------------------------------------------
c   initialisations:
c   ----------------
c

      startdrs=.true.

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

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

      CALL defrun(5)
      CALL iniconst
      CALL inigeom
      CALL inifilr
      PRINT*,'dtvr ',dtvr
      idum=-1
      xx=RAN1(idum)
      idum=0

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

c
      PRINT*,'itau  ',itau
c
      phis0=0.
c
      CALL inirappel(teq)
      DO l=1,llm
         DO j=1,jjp1
            DO i=1,iim
               h(i,j,l)=teq(i,j,l)
            ENDDO
         ENDDO
         DO j=2,jjm
            DO i=1,iim
               h(i,j,l)=h(i,j,l)+COS(rlatu(j))*(RAN1(idum)-.5)
            ENDDO
         ENDDO
         DO j=1,jjp1
            h(iip1,j,l)=h(1,j,l)
         ENDDO
      ENDDO
c
      DO j=1,jjp1
         DO i=1,iim
            phis(i,j)=phis0
            p(i,j)=1000.
         ENDDO
         phis(iip1,j)=phis(1,j)
         p(iip1,j)=p(1,j)
      ENDDO

      DO 112 j=2,jjm
         DO 113 i=1,iim
            phis(i,j)=phis(i,j)+g*50.*(RAN1(idum)-1.)*COS(rlatu(j))
113      CONTINUE
         phis(iip1,j)=phis(1,j)
112   CONTINUE
c-----------------------------------------------------------------------
c   On calcul h,ts,pks,pksf,pext:
c   -----------------------------

      DO 50 j=1,jjp1
         DO 51 i=1,iip1
            pext(i,j)=p(i,j)*aire(i,j)
51       CONTINUE
50    CONTINUE
      CALL exner(ip1jmp1,pext,aire,pks,pksf)

c-----------------------------------------------------------------------
c   calcul du vent geostrophique en equilibre avec Teq
c   a l'equateur, on applique un facteur cos4(lat)

      call geopot (iip1*jjp1,h, pks, phis, phi )
      DO j=1,jjm
         fact=cos(rlatv(j))
         fact=fact*fact
         fact=fact*fact
         fact=fact*fact
         fact=(1.-fact)/(2.*omeg*sin(rlatv(j))*(rlatu(j+1)-rlatu(j)))
         fact=-fact/rad
         DO l=1,llm
            DO i=1,iim
               u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l))
               um(j,l)=um(j,l)+u(i,j,l)/float(iim)
            ENDDO
            u(iip1,j,l)=u(1,j,l)
         ENDDO
      ENDDO
      call dump2d(jjp1,llm,um,'Vent geostrophique')

c
c-----------------------------------------------------------------------
c   calcul des champ de vent:
c   -------------------------

      DO 301 l=1,llm
         DO 302 i=1,iip1
            ucov(i,1,l)=0.
            ucov(i,jjp1,l)=0.
302      CONTINUE
         DO 304 j=2,jjm
            DO 305 i=1,iim
               ucov(i,j,l) = u(i,j,l)*cu(i,j)
305         CONTINUE
            ucov(iip1,j,l)=ucov(1,j,l)
304      CONTINUE
301   CONTINUE

      print*,301

      DO 401 l=1,llm
         DO 402 j=1,jjm
            DO 403 i=1,iim
               vcov(i,j,l) =  0.
403         CONTINUE
            vcov(iip1,j,l)=vcov(1,j,l)
402      CONTINUE
401   CONTINUE

c----------------------------------------------------------
c   calcul des champ de traceur:
c   ---------------------------
      DO iq =1, nqmx
       DO l=1,llm
          DO j=1,jjp1
             DO i=1,iim
               q(i,j,l,iq)=0.
             ENDDO
          ENDDO
       ENDDO
      ENDDO
      q(8,6,1,1) = 100.
      q(8,6,1,nqmx) = 100.



c-----------------------------------------------------------------------
c   ecriture du fichier de demarrage:
c   --------------------------------

      etot0=0.
      ptot0=0.
      stot0=0.
      ztot0=0.
      ang0=0.
147   CONTINUE

      daysec=86400.
      unit=12
c-----------------------------------------------------------------------
c   ecriture du fichier de demarrage:
c   --------------------------------
c
      CALL caldyn
     $ (0,ucov,vcov,h,pext,pks,pksf,phis,
     $  phi,.true.,du,dv,dh,dp,w, pbaru,pbarv,0.)

      PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
      PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang

c-----------------------------------------------------------------------
      unit=12
      IF(startdrs) THEN
         ierr = aslun(unit,'start.dic',
     .             unit+1,'start.dat',IDRS_CREATE)
      ELSE
         OPEN(unit,file='start',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
      day0=0
      CALL iniwrite(unit,startdrs,day0,phis)
      zz=0.
      call writedem(unit,nqmx,startdrs,zz,vcov,ucov,h,q,pext,
     .                        phis,nbetat)
      ierr = cllun(unit)
      end