*=*=*=*= newgridmars2.html =*=*=*=*
PROGRAM newgridmars2

PROGRAM newgridmars2


      PROGRAM newgridmars2
      IMPLICIT NONE

c=======================================================================
c
c   creation d'un etat initial pour le GCM martien
c     (fichiers DRS start et startfi)
c A partir  d'un start obtenu avec une autre grille
c
c (ce programme est a compiler dans la NOUVELLE grille)
c
c Il faut avoir lancer  newgridmars1 auparavant
c----------------------------------- -------------------------------------
c
c -------------------------------------
c DIMENSION DE L'ANCIENNE GRILLE
      INTEGER       imold,jmold,lmold
      PARAMETER (imold= 32,jmold=24,lmold=15)
c -------------------------------------

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



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 "description.h"
#include "ener.h"
#include "temps.h"
c ----------------------------
#include "../phymars/dimphys.h"
c-----------------------------

c Variable histoire :
      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
      REAL h(iip1,jjp1,llm),pext(iip1,jjp1)
      REAL phis(iip1,jjp1)
      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes

c autre variables dynamique nouvelle grille
      REAL pks(iip1,jjp1),pksf(iip1,jjp1)
      REAL w(iip1,jjp1,llm+1)
      INTEGER iq
      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
      REAL z_reel(iip1,jjp1)
      REAL phi(iip1,jjp1,llm)


c variable physique
      REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx)
      REAL phisfi(ngridmx),rnaturfi(ngridmx)
      REAL alb(iip1,jjp1),albfi(ngridmx)
      REAL ith(iip1,jjp1),ithfi(ngridmx)
      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
c
      INTEGER i,j,l,idum
      INTEGER unit
      REAL xx
      REAL year_day,periheli,aphelie,peri_day
      REAL obliquit,z0,emin_turb,lmixmin
      REAL emissiv,emisice(2),albedice(2),tauvis,tauir,scatalb,asfact


      EXTERNAL RAN1
      REAL RAN1
      EXTERNAL iniconst,geopot,inigeom
      INTEGER aslun, cllun
      INTEGER ierr, nbetat
      INTEGER ISMIN,lnblnk
      external ISMIN
      LOGICAL startdrs
      CHARACTER*80 file, datapath

c Variable nouvelle grille naturelle au point scalaire
      REAL us(iip1,jjp1,llm),vs(iip1,jjp1,llm)
      REAL p(iip1,jjp1)
      REAL t(iip1,jjp1,llm)
      REAL tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx)
      REAL co2iceS(iip1,jjp1)

      REAL  ptotal, co2icetotal

c     Var intermediaires : vent naturel, mais pas coord scalaire
      REAL vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)

c Variable de l'ancienne grille (lu dans newgridmars.data)
      REAL  rlonuold(imold+1), rlatvold(jmold)
      REAL sigold(lmold+1),sold(lmold),sig_sold(lmold)
      REAL time
      REAL uold(imold+1,jmold+1,lmold)
      REAL vold(imold+1,jmold+1,lmold)
      REAL Told(imold+1,jmold+1,lmold)
      REAL PSold(imold+1,jmold+1)
      REAL phisold(imold+1,jmold+1)
      REAL tab_cntrl(100)
      REAL co2iceold(imold+1,jmold+1)
      REAL tsurfold(imold+1,jmold+1)
      REAL tsoilold(imold+1,jmold+1,nsoilmx)
      REAL  ptotalold, co2icetotalold

c Variable intermediaires iutilise pour l'extrapolation verticale
      REAL var (imold+1,jmold+1,llm)

c variable intermediaire pour l'extrapolation de la pression de surface
      REAL pseaold(imold+1,jmold+1), Rgaz
      REAL psea(iip1,jjp1)


c *********************************************************************
c  Lecture des variables de l'ancienne grille,
c  (elles sont toutes dans la grille scalaire)
c ********************************************************************

      open (23,file = 'newgridmars.data',status ='old',
     &                form='unformatted')

c  Variable de start (des info du "controle" sont ds le controle de startfi)
      read (23) rlonuold,rlatvold,sigold,sold, sig_sold,time,
     &           uold,vold,told,psold,phisold, kappa
     &           ,ang0,etot0,ptot0,ztot0,stot0

c variable de startfi
      read (23) tab_cntrl,co2iceold,tsurfold,tsoilold

c Variable de controle
      read(23)  ptotalold, co2icetotalold

      close (23)

c *********************************************************************
c   reinitialisation des variables parametre du GCM martien
c *********************************************************************
c gestion du temps
c ----------------

      day_ini=tab_cntrl(3)

c Info sur la Planete Mars pour la dynamique et la physique
c ---------------------------------------------------------

      rad= tab_cntrl(5)             ! rayon de mars (m)  ~3397200 m
      daysec= tab_cntrl(10)            ! duree du sol (s)  ~88775 s
      omeg=tab_cntrl(6) ! vitesse de rotation (rad.s-1)
      g= tab_cntrl(7)                    ! gravite (m.s-2) ~3.72
      mugaz= tab_cntrl(8)              ! Masse molaire de l'atm (g.mol-1) ~43.49
c     kappa = (deja lu dans 'newgridmars.data')

c Info sur la Planete Mars pour la physique uniquement
c ----------------------------------------------------
      year_day = tab_cntrl(14)          ! duree de l'annee (sols) ~668.6
      periheli =  tab_cntrl(15)       ! dist.min. soleil-mars (Mkm) ~206.66
      aphelie = tab_cntrl(16)          ! dist.llm. soleil-mars (Mkm) ~249.22
      peri_day =  tab_cntrl(17)  ! date du perihelie (sols depuis printemps)
      obliquit = tab_cntrl(18)      ! Obliquite de la planete (deg) ~23.98


c Couche limite et Turbulence
c ---------------------------
      z0 =  tab_cntrl(19)               ! surface roughness (m) ~0.01
      emin_turb = tab_cntrl(21)          ! energie minimale ~1.e-8
      lmixmin = tab_cntrl(20)              ! longueur de melange ~100

c propriete optiques des calottes et emissivite du sol
c ----------------------------------------------------

      emissiv= tab_cntrl(26)  ! Emissivite du sol martien ~.95
      emisice(1)= tab_cntrl(24)     ! Emissivite calotte nord
      emisice(2)=tab_cntrl(25)   ! Emissivite calotte sud
      albedice(1)= tab_cntrl(22)    ! Albedo calotte nord
      albedice(2)= tab_cntrl(23)    ! Albedo calotte sud

c Proprietes des poussiere aerosol
c --------------------------------

      tauvis=tab_cntrl(27)  ! profondeur optique visible moyenne
      tauir=tab_cntrl(30) !ratio (visible opt.depth)/(mean IR opt.depth)
      scatalb= tab_cntrl(28)        ! scaterring albedo visible (~.86)
      asfact= tab_cntrl(29)  ! assymetrie factor visible   (~.79)

c
c Chemin pour trouver les donnees de surface (albedo, relief, th.inertia...)
c -------------------------------------------------------------------------
      datapath = '/dw/chourdin/MARS/data_mars'

c *********************************************************************
c  INITIALISATIONS DIVERSES
c *********************************************************************

c Initialisations diverses
c ------------------------
      day_step=180
      startdrs=.true.
      OPEN(99,file='run.def',status='old',form='formatted')
      CALL defrun(99)
      CLOSE (99)
      CALL iniconst
      CALL inigeom
      idum=-1
      xx=RAN1(idum)
      idum=0

c Initialisation coordonnees /aires
c -------------------------------

      latfi(1)=rlatu(1)
      lonfi(1)=0.
      DO j=2,jjm
         DO i=1,iim
            latfi((j-2)*iim+1+i)=rlatu(j)
            lonfi((j-2)*iim+1+i)=rlonv(i)
         ENDDO
      ENDDO
      latfi(ngridmx)=rlatu(jjp1)
      lonfi(ngridmx)=0.
      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)

c-----------------------------------------------------------------------
c   lecture de la topographie
c   ----------------------------------

c   creation du fichier des altitudes.
      file=datapath(1:lnblnk(datapath))//'/relief.lmd'
      CALL initial0(ip1jmp1,z_reel)
      CALL dataread(file,z_reel)
      DO j=1,jjp1
         DO i=1,iip1
            z_reel(i,j)=1000.*z_reel(i,j)
         ENDDO
         WRITE(6,'(64i1)') (NINT(10.*z_reel(i,j)),i=1,iip1)
      ENDDO
      CALL dump2d(iip1,jjp1,z_reel,'Altitude en m')
      CALL multscal(ip1jmp1,z_reel,g,phis)
      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)

c   lecture de l'albedo
c   -------------------
      file=datapath(1:lnblnk(datapath))//'/albedo.lmd'
      CALL dataread(file,alb)
      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)

c   lecture de l'inertie thermique
c   ------------------------------
      file=datapath(1:lnblnk(datapath))//'/thermal.lmd'
      CALL dataread(file,ith)
      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)


c ***************************************************************
c   INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables
c **************************************************************
c Interpolation horizontale puis passage dans la grille physique pour
c les variables physique
c Interpolation verticale puis horizontale pour chaque variable 3D

c Temperature de surface
      call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1,
     &                   rlonuold,rlatvold,rlonu,rlatv)
      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf)
c Glace CO2
      call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1,
     &                   rlonuold,rlatvold,rlonu,rlatv)
      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice)
c Temperature du sous-sol
      call interp_horiz(tsoilold,tsoils,
     &                  imold,jmold,iim,jjm,nsoilmx,
     &                   rlonuold,rlatvold,rlonu,rlatv)
      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil)

c temperatures atmospheriques
      write (*,*) 'told ', told (1,jmold+1,1)  ! INFO
      call interp_vert
     &    (told,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1))
      write (*,*) 'var ', var (1,jmold+1,1)  ! INFO
      call interp_horiz(var,t,imold,jmold,iim,jjm,llm,
     &                   rlonuold,rlatvold,rlonu,rlatv)
      write (*,*) 't ', t(1,jjp1,1)  ! INFO
c calcul des champ de vent; passage en vent covariant
c     write (*,*) 'uold ', uold (1,2,1)  ! INFO
      call interp_vert
     &    (uold,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1))
c     write (*,*) 'var ', var (1,2,1)  ! INFO
      call interp_horiz(var,us,imold,jmold,iim,jjm,llm,
     &                   rlonuold,rlatvold,rlonu,rlatv)
c     write (*,*) 'us ', us (1,2,1)   ! INFO

      call interp_vert
     &    (vold,var,lmold,llm,sig_sold,sig_s,(imold+1)*(jmold+1))
      call interp_horiz(var,vs,imold,jmold,iim,jjm,llm,
     &                   rlonuold,rlatvold,rlonu,rlatv)
      call  scal_wind(us,vs,unat,vnat)
c     write (*,*) 'unat ', unat (1,2,1)    ! INFO
      do l=1,llm
        do j = 1, jjp1
          do i=1,iip1
            ucov( i,j,l ) = unat( i,j,l ) * cu(i,j)
          end do
        end do
      end do
c     write (*,*) 'ucov ', ucov (1,2,1)  ! INFO
      do l=1,llm
        do j = 1, jjm
          do i=1,iip1
            vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j)
          end do
        end do
      end do

c------------------------------------------------
c Traitement special de la pression au sol :
c -------------------------------------------------------------------

c Calcul de la pression "au niveau de la mer" z = 0 dns l'ancienne grille
      Rgaz = 1000.*8.31/mugaz
      DO j=1,jmold+1
         DO i=1,imold+1
            pseaold(i,j)=psold(i,j)*EXP(phisold(i,j)/(Told(i,j,1)*Rgaz))
         ENDDO
      ENDDO

c     Test TestTest  Test  Test  Test  Test  Test  Test  Test  Test
      write (*,*)'pour i=9, j=9  pseaold,psold,phisold,told,Rgaz'
      write(*,*) pseaold(9,9),psold(9,9),phisold(9,9),told(9,9,1),Rgaz

c  Extrapolation la pression "au niveau de la mer" z = 0 dns la nouvelle grille
      call interp_horiz(pseaold,psea,imold,jmold,iim,jjm,1,
     &                   rlonuold,rlatvold,rlonu,rlatv)

c Calcul de la pression avec le relief de la nouvelle grille
      DO j=1,jjp1
         DO i=1,iip1
            p(i,j) = psea(i,j)*EXP(-phis(i,j)/(t(i,j,1)*Rgaz))
            pext(i,j)=p(i,j)*aire(i,j)
         ENDDO
      ENDDO

c -------------------------------------------------------------------
c On assure la concervation de la masse de l'atmosphere + calottes
c -------------------------------------------------------------------

      ptotal =  0.
      co2icetotal = 0.
      DO j=1,jjp1
         DO i=1,iim
            ptotal=ptotal+pext(i,j)/g
            co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
         ENDDO
      ENDDO

      write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold
      DO j=1,jjp1
         DO i=1,iip1
            pext(i,j)=pext(i,j) * ptotalold/ptotal
            p(i,j)=p(i,j) * ptotalold/ptotal
         ENDDO
      ENDDO

      if ( co2icetotalold.ne.0.) then
      write(*,*)'Ratio new ice./old ice =',co2icetotalold/co2icetotalold
         DO j=1,jjp1
            DO i=1,iip1
               co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal
            ENDDO
         ENDDO
      end if




c-----------------------------------------------------------------------
c   Initialisation  h,pks,pksf:
c   -------------------------------
c
      DO l=1,llm
         DO j=1,jjp1
            DO i=1,iip1
               h(i,j,l) = t(i,j,l)*cpp/(s(l)*p(i,j)**kappa)
            ENDDO
         ENDDO
      ENDDO
c
      DO j=1,jjp1
         DO i=1,iip1
            pks(i,j) =p(i,j)**kappa
            pksf(i,j)=pks(i,j)
         ENDDO
      ENDDO
c
c----------------------------------------------------------
c   Initialisation    des champ de traceur:
c   ---------------------------
      DO iq =1, nqmx
       DO l=1,llm
          DO j=1,jjp1
             DO i=1,iip1
               q(i,j,l,iq)=0.
             ENDDO
          ENDDO
       ENDDO
      ENDDO
c----------------------------------------------------------


c *********************************************************************
c    Initialisation de la physique / ecriture de startfi :
c *********************************************************************

      CALL ini_fi(ngridmx,llm,startdrs,
     $           day_ini,time,daysec, 0.,0.,
     $           latfi,lonfi,airefi,phisfi,rnaturfi,
     $           albfi,ithfi,
     $           rad,g,r,cpp,mugaz,omeg,tsurf,tsoil,co2ice,
     $           year_day,periheli,aphelie,peri_day,
     $           obliquit,z0,emin_turb,lmixmin,
     $           emissiv,emisice,albedice,
     $           tauvis,tauir,scatalb,asfact)



c-----------------------------------------------------------------------
c   ecriture du fichier de demarage: start
c   --------------------------------------
c
      CALL inifilr
      CALL exner(ip1jmp1,pext,aire,pks,pksf)
      CALL geopot  (ip1jmp1, h     , pks   , phis    , phi          )
      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 de creation du fichier start. Existe deja ?'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
      CALL iniwrite(unit,startdrs,day_ini,phis)
      call WRITEDEM(unit,nqmx,startdrs,time,vcov,ucov,h,q,pext,
     .                        phis,nbetat)
      ierr = cllun(unit)

c-----------------------------------------------------------------------
c Info pour controler
c -------------------
      ptotal =0
      co2icetotal = 0.
      DO j=1,jjp1
         DO i=1,iim
            ptotal=ptotal+pext(i,j)/g
            co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
         ENDDO
      ENDDO
      write(*,*)'Ancienne grille: masse de l''atm :',ptotalold
      write(*,*)'Nouvelle grille: masse de l''atm :',ptotal
      write(*,*)
      write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold
      write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal

      end