*=*=*=*= testphys1d.html =*=*=*=*
PROGRAM testphys1d

PROGRAM testphys1d


      PROGRAM testphys1d
      IMPLICIT NONE

c   subject:
c   --------
c   PROGRAM useful to run physical part of the martian GCM in a 1D column
c   to run it : tesphys1d.e < tesphys1d.def
c
c   author: Frederic Hourdin, R.Fournier,F.Forget
c   -------


#include "dimensions.h"
#include "dimphys.h"
#include "dimradmars.h"
#include "comgeomfi.h"
#include "surfdat.h"
#include "comdiurn.h"
#include "callkeys.h"
#include "comcstfi.h"
#include "planete.h"
#include "comsaison.h"
#include "yomaer.h"
#include "aerdata.h"
#include "control.h"
#include "comvert.h"
#include "drsdef.h"

c.......................................................................
c  pour les sorties GRADS-1D
c
#include "comg1d.h"
c
c  pour les sorties GRADS-1D
c.......................................................................
c  declarations
c
      INTEGER unit,aslun,ierr
      LOGICAL ldrs
c
      INTEGER day0
      REAL ptif,gru,grv
c
      INTEGER nlayer,nlevel,nsoil,ndt
      INTEGER ilayer,ilevel,isoil,idt
      LOGICAl firstcall,lastcall
c
      REAL pks
      REAL phi(nlayermx),h(nlayermx)
      REAL zlay(nlayermx),play(nlayermx),plev(nlayermx+1)
      INTEGER day
      REAL time
      REAL psurf,tsurf
      REAL dpsurf
      REAL u(nlayermx),v(nlayermx),w(nlayermx),temp(nlayermx)
      REAL du(nlayermx),dv(nlayermx),dtemp(nlayermx)
      REAL dudyn(nlayermx),dvdyn(nlayermx),dtempdyn(nlayermx)
      REAL q(nlayermx,nqmx)
      REAL dq(nlayermx,nqmx)
      REAL dqdyn(nlayermx,nqmx)
      REAL tsoil(nsoilmx)
      REAL co2ice,emis
      REAL q2(nlayermx+1)
c
c  declarations
c.......................................................................
c  bidouilles
c
      REAL temporaire(nlayermx)
      REAL thaut,tbas
      CHARACTER*100 spectre
      REAL fab(nlayermx+1),fdb(nlayermx+1)
      REAL tmp1(0:nlayermx),tmp2(0:nlayermx)
      REAL logps10(nlayermx)
c
c  bidouilles
c.......................................................................
c  chargement des constantes
c
      pi=2.E+0*asin(1.E+0)
c
c Pression de reference sur la planete
c ------------------------------------
c
      PRINT *,'pression au sol'
      READ(5,*) psurf

c
c Info sur la Planete Mars pour la dynamique et la physique
c ---------------------------------------------------------
c
      rad=3397200.               ! rayon de mars (m)  ~3397200 m
      daysec=88775.              ! duree du sol (s)  ~88775 s
      omeg=4.*asin(1.)/(daysec)  ! vitesse de rotation (rad.s-1)
      g=3.72                     ! gravite (m.s-2) ~3.72
      mugaz=43.49                ! Masse molaire de l'atm (g.mol-1) ~43.49
      rcp=.256793                ! = r/cp  ~0.256793
      r= 8.314511E+0 *1000.E+0/mugaz
      cpp= r/rcp
c
c Info sur la Planete Mars pour la physique uniquement
c ----------------------------------------------------
c
      year_day = 668.6           ! duree de l'annee (sols) ~668.6
      periheli = 206.66          ! dist.min. soleil-mars (Mkm) ~206.66
      aphelie = 249.22           ! dist.max. soleil-mars (Mkm) ~249.22
      peri_day =  485.           ! date du perihelie (sols depuis printemps)
      obliquit = 23.98           ! Obliquite de la planete (deg) ~23.98
c
c Couche limite et Turbulence
c ---------------------------
c
      z0 =  1.e-2                ! surface roughness (m) ~0.01
      emin_turb = 1.e-6          ! energie minimale ~1.e-8
      lmixmin = 30               ! longueur de melange ~100
c
c propriete optiques des calottes et emissivite du sol
c ----------------------------------------------------
c
      emissiv=1                 ! Emissivite du sol martien ~.95
      emisice(1)=1            ! Emissivite calotte nord
      emisice(2)=1            ! Emissivite calotte sud
      albedice(1)=0.4            ! Albedo calotte nord
      albedice(2)=0.4            ! Albedo calotte sud
      iceradius(1) = 100.e-6     ! mean scat radius of CO2 snow (north)
      iceradius(2) = 100.e-6     ! mean scat radius of CO2 snow (south)
      dtemisice(1) = 2.          ! time scale for snow metamorphism (north)
      dtemisice(2) = 2.          ! time scale for snow metamorphism (south
c
c Proprietes des poussiere aerosol
c --------------------------------
c
      tauvis= 0.                 ! profondeur optique visible moyenne
      PRINT *,'epaisseur optique dans le visibile ?'
      READ(5,*) tauvis
c
c Date (en jour depuis le solstice de printemps) du debut du run
c --------------------------------------------------------------
c
      day0 = 0
      PRINT *,'date de depart ?'
      READ(5,*) day0
c
c  declinaison
c  -----------
c
      declin=-24.8E+0
      declin=declin*pi/180.E+0
c
c  distance soleil
c  ---------------
c
      dist_sol=1.4E+0
c
c  albedo / inertie du sol
c  -----------------------
c
      albedodat(1)=0.24E+0
      inertiedat(1)=400.E+0
c
c  latitude/longitude
c  ------------------
c
      PRINT *,'latitude en degres ?'
      READ(5,*) lati(1)
      lati(1)=lati(1)*pi/180.E+0
      long(1)=0.E+0
      long(1)=long(1)*pi/180.E+0
c
c  pour le schema d'ondes de gravite
c  ---------------------------------
c
      zmea(1)=0.E+0
      zstd(1)=0.E+0
      zsig(1)=0.E+0
      zgam(1)=0.E+0
      zthe(1)=0.E+0
c
c  chargement des constantes
c.......................................................................
c  la discretisation
c
      nlayer=nlayermx
      nlevel=nlayer+1
      nsoil=nsoilmx
      PRINT *,'nombre de pas de temps par jour ?'
      READ(5,*) day_step
      PRINT *,'nombre de jours simules ?'
      READ(5,*) ndt
c MOMO fixe a 1 pas de temps
c     ndt=ndt*day_step
      ndt=1
      dtphys=daysec/day_step
c
c  la discretisation
c.......................................................................
c  "inifis" reproduit un certain nombre d'initialisations deja faites
c
c  + lecture des clefs de callphys.def
c  + calcul de la frequence d'appel au rayonnement
c  + calcul des sinus et cosinus des longitude latitude
c
c  NOTE :
c  la surface de chaque maille est inutile en 1D --->
      area(1)=1.E+0
c
      call inifis(1,nlayermx,
     &           daysec,
     &           day0,dtphys,
     &           lati,long,area,
     &           rad,g,r,cpp)
c
c.......................................................................
c  les constantes pour le 1D
c
      ptif=2.E+0*omeg*sinlat(1)
c
c  vent geostrophique
c
      PRINT *,'composante vers l''est du vent geostrophique (U) ?'
      READ(5,*) gru
      PRINT *,'composante vers le nord du vent geostrophique (V) ?'
      READ(5,*) grv

c
c  les constantes pour le 1D
c.......................................................................
c  initialisations
c
c  debut
c  -----
c
      day=day0
      PRINT *,'heure de debut de simulation (entre 0 et 24) ?'
      READ(5,*) time
      time=time/24.E+0
c
c  calcul des pressions et altitudes en utilisant les niveaux sigma
c  ----------------------------------------------------------------
c
      CALL  disvert(nlayer,rcp,sig,dsig,s,ds,dsig1,sdsig)
      DO ilayer=1,nlayer
         sig_s(ilayer)=s(ilayer)**(1.E+0/rcp)
c._.         play(ilayer)=psurf*s(ilayer)**(1.E+0/rcp)
         play(ilayer)=psurf*sig_s(ilayer)
         zlay(ilayer)=-200.E+0 *r*log(s(ilayer))
     &   /(1000.E+0 *g*rcp)
         logps10(ilayer)=-log(play(ilayer)/100.E+0/10.E+0)
      ENDDO
      DO ilevel=1,nlevel
         plev(ilevel)=psurf*sig(ilevel)
      ENDDO
c
c  profil de temperature au premier appel
c  --------------------------------------
c
      pks=psurf**rcp
      tmp1(0)=0.E+0
      DO ilayer=1,nlayer
        tmp1(ilayer)=zlay(ilayer)
      ENDDO
      call profile(nlayer+1,tmp1,tmp2)
      tsurf=tmp2(0)
      DO ilayer=1,nlayer
        temp(ilayer)=tmp2(ilayer)
c._.        temp(ilayer)=180.E+0
      ENDDO
c
c le profil de temperature lineaire en pression.
c si le rapport de melange des poussieres est independant de
c la pression (voir dans PHYSIQ.F), on se retrouve avec une
c configuration ou le profil de temperature est lineaire en
c fonction de l'epaisseur optique -->
c      tsurf=215.E+0
c      tbas=tsurf-20.E+0
c      thaut=130.E+0
c      DO ilayer=1,nlayer
c        temp(ilayer)=play(ilayer)/psurf*(tbas-thaut) + thaut
c      ENDDO
c
c  enthalpie potentielle
c
      DO ilayer=1,nlayer
        h(ilayer)=cpp*temp(ilayer)/(pks*s(ilayer))
      ENDDO
      phi(1)=pks*h(1)*(1.E+0-s(1))
      DO ilayer=2,nlayer
         phi(ilayer)=phi(ilayer-1)+
     &               pks*(h(ilayer-1)+h(ilayer))*.5E+0
     &                  *(s(ilayer-1)-s(ilayer))
      ENDDO
c
c  temperature du sous-sol
c  -----------------------
c
      DO isoil=1,nsoil
         tsoil(isoil)=tsurf
      ENDDO
c
c  initialisation des vitesses au vent geostrophique
c  -------------------------------------------------
c
      DO ilayer=1,nlayer
         u(ilayer)=gru
         v(ilayer)=grv
      ENDDO
c
c  glace de CO2 au sol
c  -------------------
c
      co2ice=0.E+0
      PRINT *,'co2ice (kg.m-2)'
      READ(5,*) co2ice

c
c  emissivite
c  ----------
c
      emis=emissiv
      IF (co2ice.eq.1.E+0) THEN
         emis=emisice(1)
         IF(lati(1).LT.0) emis=emisice(2)
      ENDIF
c
c  energie cinetique turbulente
c  ----------------------------
c
      DO ilevel=1,nlevel
         q2(ilevel)=0.E+0
      ENDDO
c
c  initialisations
c.......................................................................
c  initialisation pour GRADS-1D
c
      g1d_nlayer=nlayer
      g1d_nomfich='grads1d.dat'
      g1d_unitfich=40
      g1d_nomctl='grads1d.ctl'
      g1d_unitctl=41
      g1d_premier=.true.
c
c  initialisation pour GRADS-1D
c.......................................................................
c  un calcul radiatif monochromatique de reference
c
c  on fait un decoupage en nlayer couches de meme epaisseur optique.
c  l'epaisseur optique est donnee a 0.67 micron.
c  en sortie on recuppere les flux dans chacune des bandes de l'IR
c  (flux ascendant et flux descendant a l'interface des couches).
c  les numerotations sont dans l'ordre du GCM : du bas vers le
c  haut, "1" pour le sol et "nlayer+1" pour la limite haute.
c
c      spectre='francois_ir.fic'
c      CALL radref(spectre,longrefir,tauvis*psurf/700.E+0/solsir
c     &           ,tsurf,tbas,thaut,nlayer,fab,fdb)
c
c petite sortie pour gnuplot
c        open(155,file='temp.gnu',status='new')
c        open(156,file='masse.gnu',status='new')
c        open(157,file='ref.gnu',status='new')
c        write(156,*) nlevel
c        DO ilayer=1,nlayer
c          write(155,*) psurf-play(ilayer),temp(ilayer)
c        ENDDO
c        DO ilevel=1,nlevel
c          write(156,*) psurf-plev(ilevel)
c          write(157,*) psurf*REAL(ilevel-1)/REAL(nlevel-1)
c     &                ,fab(ilevel),fdb(ilevel)
c        ENDDO
c        close(155)
c        close(156)
c        close(157)
c
c.......................................................................
c  ecriture de "startfi"
c
c  NOTE :
c  le geopotentiel au sol est inutile en 1D car tout est controle
c  par la pression de surface --->
      phisfi(1)=0.E+0
c
      unit=92
      ldrs=.FALSE.
      IF (ldrs) THEN
         ierr = aslun(unit,'startfi.dic',
     &             unit+1,'startfi',IDRS_CREATE)
      ELSE
         OPEN(unit,FILE='startfi',FORM='unformatted')
      ENDIF
c
      CALL ini_fi(1,nlayer,unit,ldrs,
     $           day0,time,daysec,0.E+0,dtphys,
     $           lati,long,area,phisfi,1.E+0,
     $           albedodat,inertiedat,
     $           rad,g,r,cpp,mugaz,omeg,tsurf,tsoil,co2ice,
     $           year_day,periheli,aphelie,peri_day,
     $           obliquit,z0,emin_turb,lmixmin,
     $           emissiv,emisice,albedice,
     $           tauvis,0.E+0,0.E+0,0.E+0,
     $           emis,iceradius,dtemisice,q2,
     $           zmea,zstd,zsig,zgam,zthe)

c
      CLOSE(unit)
c
c  ecriture de "startfi"
c.......................................................................
c  iteration dans le temps
c
      firstcall=.true.
      lastcall=.false.
      DO idt=1,ndt
        IF (idt.eq.ndt) lastcall=.true.
c
c.......................................................................
c  sorties GRADS-1D pour u, v et temp
c
      g1d_tmp1='u'
      g1d_tmp2='vent : composante vers l''est'
      CALL writeg1d(1,nlayer,u,g1d_tmp1,g1d_tmp2)
c
      g1d_tmp1='v'
      g1d_tmp2='vent : composante vers le nord'
      CALL writeg1d(1,nlayer,v,g1d_tmp1,g1d_tmp2)
c
      g1d_tmp1='temp'
      g1d_tmp2='temperature'
      CALL writeg1d(1,nlayer,temp,g1d_tmp1,g1d_tmp2)
c
      g1d_tmp1='p'
      g1d_tmp2='pression'
      CALL writeg1d(1,nlayer,play,g1d_tmp1,g1d_tmp2)
c
      g1d_tmp1='psurf'
      g1d_tmp2='pression au sol'
      CALL writeg1d(1,1,plev(1),g1d_tmp1,g1d_tmp2)
c
c  sorties GRADS-1D pour u, v et temp
c
c.......................................................................
c  appel de la physique
c
      CALL physiq(1.E+0,1,nlayer,nqmx,
     $            firstcall,lastcall,
     $            day,time,dtphys,
     $            plev,play,phi,
     $            u,v,temp,q,
     $            dudyn,dvdyn,dtempdyn,dqdyn,
     $            w,
     $            du,dv,dtemp,dq,dpsurf)


c
c.......................................................................
c  evolution du vent : modele 1D
c
c  la physique calcule les derivees temporelles de u et v.
c  on y rajoute betement un effet Coriolis.
c
      DO ilayer=1,nlayer
         du(ilayer)=du(ilayer)+ptif*(v(ilayer)-grv)
         dv(ilayer)=dv(ilayer)+ptif*(-u(ilayer)+gru)
      ENDDO

c  Pour certain test :
      if(lati(1).eq.0.) then
        DO ilayer=1,nlayer
           du(ilayer)=du(ilayer)+ (gru-u(ilayer))/1.e4
           dv(ilayer)=dv(ilayer)+ (grv-v(ilayer))/1.e4
        ENDDO
      end if
c
c.......................................................................
c  calcul des vitesses et temperature au pas de temps suivant
c
      firstcall=.false.
      time=time+dtphys/daysec
      IF (time.gt.1.E+0) then
          time=time-1.E+0
          day=day+1
      ENDIF
      DO ilayer=1,nlayer
         u(ilayer)=u(ilayer)+dtphys*du(ilayer)
         v(ilayer)=v(ilayer)+dtphys*dv(ilayer)
         temp(ilayer)=temp(ilayer)+dtphys*dtemp(ilayer)
      ENDDO


c         WRITE (78,*) time*24,acos(mu0(1))*180/pi


c.......................................................................
c  iteration dans le temps
c
      ENDDO
c
c.......................................................................
c  "fin pour GRADS-1D"
c
      CALL endg1d(1,nlayer,zlay,ndt)
c._.          CALL endg1d(1,nlayer,logps10,ndt)
c
c  "fin pour GRADS-1D"
c.......................................................................
c
      END
c c....................................................................... c *=*=*=*= gr_fi_dyn.html =*=*=*=*
subroutine gr_fi_dyn

subroutine gr_fi_dyn


      subroutine gr_fi_dyn
      RETURN
      END
c c....................................................................... c *=*=*=*= iniwrite.html =*=*=*=*
subroutine iniwrite

subroutine iniwrite


      subroutine iniwrite
      RETURN
      END
c c....................................................................... c *=*=*=*= disvert.html =*=*=*=*
SUBROUTINE disvert

SUBROUTINE disvert


      SUBROUTINE disvert(llm,kappa,sig,dsig,s,ds,dsig1,sdsig)
      IMPLICIT NONE
c
c=======================================================================
c
c
c    s = sigma ** kappa   :  coordonnee  verticale
c    dsig(l)            : epaisseur de la couche l ds la coord.  s
c    sig(l)             : sigma a l'interface des couches l et l-1
c    ds(l)              : distance entre les couches l et l-1 en coord.s
c
c=======================================================================
c
c   declarations:
c   -------------
c
      integer llm
      real kappa,pi,x
      real sig(llm+1),dsig(llm),s(llm),ds(llm),dsig1(llm),sdsig(llm)
c
      integer ll,l,lllm,lllmm1,lllmp1
      real abid,abid2,som,quoi,quand,snorm,sigbid,sbid
      REAL alpha,beta,h,zd,dz0,dz1
      REAL gama,delta,deltaz,np

      real nhaut
      INTEGER ierr,ierr1,ierr2
      real puiss

      real asig,bsig,csig,esig,zsig,p,zz,sig1
      REAL SSUM,z1,z2
      EXTERNAL SSUM
c
c-----------------------------------------------------------------------
c
      lllm=llm
      lllmm1=lllm-1
      lllmp1=lllm+1
      pi=2.*asin(1.)

      OPEN(99,file='sigma.def',status='old',form='formatted',
     s   iostat=ierr1)
      if(ierr1.ne.0) then
         close(99)
         open(99,file='esasig.def',status='old',form='formatted',
     s   iostat=ierr2)
      endif


c-----------------------------------------------------------------------
c   cas 1 on lit les options dans sigma.def:
c   ----------------------------------------


      if (ierr1.eq.0) then
         READ(99,*) deltaz
         READ(99,*) h
         READ(99,*) beta
         READ(99,*) gama
         READ(99,*) delta
         READ(99,*) np
         CLOSE(99)
         alpha=deltaz/(llm*h)
          do l= 1, llm
             dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*
     $          ( (tanh(gama*l)/tanh(gama*llm))**np +
     $            (1.-l/FLOAT(llm))*delta )
          enddo

          sig(1)=1.
          do l=1,llm-1
             sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
          enddo
          sig(llm+1)=0.

          do l = 1, llm
             dsig(l) = sig(l)-sig(l+1)
          enddo

      else if(ierr2.eq.0) then

         READ(99,*) h
         READ(99,*) dz0
         READ(99,*) dz1
         READ(99,*) nhaut
         CLOSE(99)

         dz0=dz0/h
         dz1=dz1/h

         sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)

         esig=1.
         do l=1,20
            print*,'esig=',esig
            esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
         enddo
         csig=(1./sig1-1.)/(exp(esig)-1.)

         DO L = 2, llm
           zz=csig*(exp(esig*(l-1.))-1.)
           sig(l) =1./(1.+zz)
     &    * tanh(.5*(llm+1-l)/nhaut)
         ENDDO
         sig(1)=1.
         sig(llm+1)=0.

         do  l = 1, llm
         dsig(l) =sig(l)-sig(l+1)
         enddo

      else

         print*,'WARNING!!! Ancienne discretisation verticale'
         stop
         h=7.
         snorm  = 0.
         do l = 1, llm
            x = 2.*asin(1.) * (float(l)-0.5) / float(llm+1)
            dsig(l) = 1.0 + 7.0 * sin(x)**2
            snorm = snorm + dsig(l)
         enddo
         snorm = 1./snorm
         do l = 1, llm
            dsig(l) = dsig(l)*snorm
         enddo
         sig(llm+1) = 0.
         do l = llm, 1, -1
            sig(l) = sig(l+1) + dsig(l)
         enddo

      endif

c-----------------------------------------------------------------------
c   calcul de s, ds, sdsig...
c   -------------------------

       quoi      = 1. + 2.* kappa
       s( llm )  = 1.
       s(lllmm1) = quoi
       IF( llm.gt.2 )  THEN
          DO  ll = 2, lllmm1
             l         = lllmp1 - ll
             quand     = sig(l+1)/ sig(l)
             s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
          ENDDO
       END IF
c
       snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
       DO l = 1, llm
          s(l)    = s(l)/ snorm
       ENDDO

       DO l = 2, llm
          ds(l)   = s(l-1) - s(l)
       ENDDO
       ds(1)  = 1. - s(1)
c
       DO l  = 1, llm
          sdsig(l) = s(l) * dsig(l)
          dsig1(l)= 1./dsig(l)
       ENDDO

c-----------------------------------------------------------------------
c
c     Diagnostique sur la discretisation verticale:
c     ---------------------------------------------
c
      print*,'Diagnostique de la discretisation verticale'
      print*
      print*,'comparaison de sig(l) et (s(l)+s(l+1))/2)**(1/K)'
      do 14 l=1,llm-1
         sigbid=(0.5*(s(l)+s(l+1)))**(1./kappa)
         print*,'sig(',l+1,')  = ',sig(l+1),
     S           '    valeur approchee :',sigbid,'   ',dsig(l)
14    continue
      print*
      print*,'comparaison de s(l) et (sig(l)+sig(l+1))/2)**K'
      do 15 l=1,llm
         sbid=(0.5*(sig(l+1)+sig(l)))**kappa
         print*,'  s(',l,')  = ',s(l),
     S           '    valeur approchee :',sbid
15    continue
c
      PRINT*,'Altitude approchee z,dz'
      PRINT*
      z1=0.
      print*,'   l       Z      DZ      Ztop   dsig'
      DO 18 l=1,llm-1
         z2=-h*log(sig(l+1))
         write(*,'(i5,3x,4f8.4)') l,-h*log(s(l))/kappa,z2-z1,z2
     &    ,dsig(l)
         write(14,'(3x,i5,1f10.4)') l,-h*log(s(l))/kappa
         z1=z2
18    CONTINUE
      write(*,'(i5,3x,3f8.4)') l,-h*log(s(llm))/kappa
      write(14,'(3x,i5,1f10.4)') l,-h*log(s(llm))/kappa


c-----------------------------------------------------------------------
      RETURN
      END