*=*=*=*= radia1d.html =*=*=*=*
PROGRAM radia1d

PROGRAM radia1d


      PROGRAM radia1d
      IMPLICIT NONE
#include "dimensions.h"
#include "dimphys.h"
#include "comgeomfi.h"
#include "surfdat.h"
#include "comdiurn.h"
#include "callkeys.h"
#include "comcstfi.h"
#include "planete.h"
#include "comsaison.h"

#include "comg1d.h"
#include "comvert.h"


c    Arguments :
c    -----------

      INTEGER ngrid,nlayer,nq

      REAL plev(nlayermx+1),play(nlayermx)
      REAL temp(nlayermx)
      REAL psrf

c   dynamial tendencies

      INTEGER l,ierr,aslun,nlevel,iaer,ilayer,ilevel
c
      REAL day_ini,time,longitude,latitude
      REAL zlay(nlayermx)
      REAL ztlev(nlayermx+1)
      REAL zplanck
      REAL zrad(nlayermx),zradc(nlayermx)
      REAL zdum1(nlayermx)
      REAL zdum2(nlayermx)
      REAL zdum3(nlayermx)
      REAL zdum4(nlayermx)
      REAL zdum5(nlayermx)
      REAL stephan
      REAL ztim1,ztim2,ztim3
      REAL zco2,zp
      REAL ls,zmax,tau,tau_tot
      REAL dtlw(nlayermx),dtsw(nlayermx)
      REAL dtlwcl(nlayermx),dtswcl(nlayermx)
      REAL zflux(6)

      REAL aerosol(nlayermx,5),cst_aer,pview
      REAL tsurf,tsoil(nsoilmx)
      REAL co2ice,albedo(2),emis
      REAL dtrad(nlayermx),fluxrad

      REAL unjours

      real couche(ngridmx,nlayermx)
     .  ,  space(ngridmx,nlayermx)
     .  ,  sol(ngridmx,nlayermx)
     .  ,  pnet(ngridmx,nlayermx)
     .  ,  pcolc_lwmain(ngridmx,nlayermx)

      REAL tmp1(0:nlayermx),tmp2(0:nlayermx)
      REAL logps10(nlayermx)

      DATA stephan/5.67e-08/
      DATA psrf,zmax/700.,9./
      DATA ls,time,latitude,longitude/0.,12.,0.,0./
      DATA diurnal/.true./
      DATA tau/.5/

c   WARNING declin and dist_sol are prescribed instead of Ls
      DATA declin,dist_sol/-24.8,1.4/

c-----------------------------------------------------------------------
c    1. Initialisations :
c    --------------------


c     PRINT*,'tau?'
c     READ(5,*) tau
c     PRINT*,'time 0 to 24 h'
c     READ(5,*) time
c     PRINT*,'latitude (degrees)'
c     READ(5,*) latitude
      tau=0
      time=0
      latitude=0



      pi=2.*asin(1.)
      ls=ls*pi/180.
      time=time/24.
      latitude=latitude*pi/180.
      longitude=longitude*pi/180.
      declin=declin*pi/180.

      ngrid=1
      nlayer=nlayermx
      nlevel=nlayer+1

      rad=3397200.
      omeg=4.*asin(1.)/(88775.)
      g=3.72
      mugaz=43.49
      rcp=.256793
      unjours=88775.
      daysec=unjours
      r       = 8.314511*1000./mugaz
      cpp     = r/rcp
      PRINT*,'Cp  =  ',cpp
      PRINT*,'R   =  ',r

      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

      xradia = 1
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)=psrf*s(ilayer)**(1.E+0/rcp)
         play(ilayer)=psrf*sig_s(ilayer)
         zlay(ilayer)=-200.E+0 *r*log(s(ilayer))
     &   /(1000.E+0 *g*rcp)
c        logps10(ilayer)=-log(play(ilayer)/100.E+0/10.E+0)
         logps10(ilayer)=-10*log(play(ilayer)/psrf)
      ENDDO
      DO ilevel=1,nlevel
         plev(ilevel)=psrf*sig(ilevel)
      ENDDO


c     DO l=1,nlayer
c        zlay(l)=zmax*(l-.5)/nlayer
c        plev(l)=psrf*exp(-zmax*(l-1.)/nlayer)
c        play(l)=psrf*exp(-zlay(l))
c     ENDDO
c     plev(nlevel)=0.

c
c  profil de temperature
c  ---------------------
c

      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     DO l=1,nlayer
c        temp(l)=200.
c     ENDDO

      DO l=1,nlayer
         dtrad(l)=0.
      ENDDO
      fluxrad=0.

      albedo(1)=.24
      albedo(2)=.24
      emis=1.
      CALL iniorbit(aphelie,periheli,year_day,peri_day,obliquit)

c  a total otempical detemph of .2 for Ps=700Pa
      cst_aer=tau/700.
      pview=1.66
      CALL sucst(66,19900101,8000000,g,rad,mugaz,rcp,unjours)
      CALL surad(6)

      IF (ngrid.NE.ngridmx) THEN
         PRINT*,'STOP in inifis'
         PRINT*,'Probleme de dimenesions :'
         PRINT*,'ngrid     = ',ngrid
         PRINT*,'ngridmx   = ',ngridmx
         STOP
      ENDIF

c.......................................................................
c  initialisation pour GRADS-1D
c
      g1d_nlayer=nlayer+1   ! une couche en plus pour le sol
      g1d_nomfich='grads1d.dat'
      g1d_unitfich=40
      g1d_nomctl='grads1d.ctl'
      g1d_unitctl=41
      g1d_premier=.true.
      g2d_premier=.true.
c
c  initialisation pour GRADS-1D
c.......................................................................
c-----------------------------------------------------------------------
c    2. Calcul of the radiative tendencies :
c    ---------------------------------------


      CALL orbite(ls,dist_sol,declin)
      IF(diurnal) THEN
         ztim1=SIN(declin)
         ztim2=COS(declin)*COS(2.*pi*(time-.5))
         ztim3=-COS(declin)*SIN(2.*pi*(time-.5))
         CALL solang(ngrid,sin(longitude),cos(longitude),
     s   sin(latitude),cos(latitude),
     s   ztim1,ztim2,ztim3,
     s   mu0,fract)
         PRINT*,'time, declin, sinlon,coslon,sinlat,coslat'
         PRINT*,time, declin,sin(longitude),cos(longitude),
     s   sin(latitude),cos(latitude)
      ELSE
         CALL mucorr(ngrid,declin, lati, mu0, fract,10000.,rad)
      ENDIF

c    2.2 Calcul of the radiative tendencies and fluxes:
c    --------------------------------------------------

c   2.1.1 layers
      tau_tot=0.
      DO l=1,nlayer
         zp=plev(1)/play(l)
         aerosol(l,1)=amax1(cst_aer*
     s            (plev(l)-plev(l+1))
     s            *exp(.03*(1.-zp)),1.e-33)
         aerosol(l,1)=amax1(
     s   tau*(plev(l)-plev(l+1))/plev(1)
     s   *exp(.007*(1.-zp)),1.e-33)
         tau_tot=tau_tot+aerosol(l,1)
      ENDDO
      PRINT*,'tau total',tau_tot
      DO l=1,nlayermx
         aerosol(l,1)=aerosol(l,1)*tau/tau_tot
      ENDDO

c  2.1.2 levels

c  Extrapolation for the air temperature above the surface
      ztlev(1)=temp(1)+
     s     (plev(1)-play(1))*
     s     (temp(1)-temp(2))/(play(1)-play(2))

      DO l=2,nlevel-1
         ztlev(l)=0.5*(temp(l-1)+temp(l))
      ENDDO

      ztlev(nlevel)=temp(nlayer)
      PRINT*,'temp'

      DO l=1,nlayer
         zdum1(l)=0.
         zdum2(l)=0.
         zdum3(l)=0.
         zdum4(l)=0.
         zdum5(l)=0.
         DO iaer=2,5
            aerosol(l,iaer)=0.
         ENDDO
      ENDDO

c    2.3 Calcul of the radiative tendencies and fluxes:
c    --------------------------------------------------

      zco2=.95

      PRINT*,'    Tlay    Tlev     Play      Plev       z      aerosol
     .    dT(SW)/dt     dT(LW)/dt  (K/day)'
      DO l=1,nlayer
         WRITE(*,'(i3,2f7.1,2e11.3,f6.1,3e14.5)') l,
     s   temp(l),ztlev(l),play(l),plev(l),zlay(l),
     s   g*aerosol(l,1)/(plev(l)-plev(l+1)),dtswcl(l),dtlwcl(l)
      ENDDO

      PRINT*,'CALL radite'

      CALL radite(ngrid,nlayer,0,6,1,1,
     $         aerosol,albedo,zco2,zdum4,emis,
     $         mu0,zdum5,
     $         plev,play,zdum1,zdum2,zdum3,ztlev,tsurf,temp,pview,
     $         dtlw,dtsw,dtlwcl,dtswcl,zflux,zrad,zradc,
     $         fract,dist_sol
     .         ,couche,sol,space,pnet,pcolc_lwmain)


c    2.4 total flux and tendencies:
c    ------------------------------

c    2.4.1 fluxes

      fluxrad=emis*zflux(4)
     $   +zflux(5)*(1.-albedo(1))
     $   +zflux(6)*(1.-albedo(2))
      zplanck=tsurf*tsurf
      zplanck=emis*
     $   stephan*zplanck*zplanck
      fluxrad=fluxrad-zplanck

c    2.4.2 temperature tendencies

      DO l=1,nlayer
         dtrad(l)=(dtsw(l)+dtlw(l))/unjours
         dtsw(l)=cpp*dtsw(l)/unjours
         dtlw(l)=dtlw(l)
      ENDDO


c    2.5 Transformation of the radiative tendencies:
c    -----------------------------------------------

      PRINT*,'Diagnotique for the radaition'
      PRINT*,'albedo, emissiv, mu0,fract,pview,Frad,Planck'
      PRINT*,albedo(1),emis,mu0(1),fract(1),pview,
     .     fluxrad,zplanck
      PRINT*,'insolation',fract(1)*mu0(1)*1370.,'    Fsol=',
     s   zflux(5)+zflux(6)
      PRINT*,'unjours',unjours
      PRINT*,'    Tlay    Tlev     Play      Plev       z      aerosol
     .    dT(SW)/dt     dT(LW)/dt  (K/day)'
      DO l=1,nlayer
         WRITE(*,'(i3,2f7.1,2e11.3,f6.1,3e14.5)') l,
     s   temp(l),ztlev(l),play(l),plev(l),zlay(l),
     s   g*aerosol(l,1)/(plev(l)-plev(l+1)),dtswcl(l),dtlwcl(l)
c        WRITE(55,'(2e15.5)') -dtlw(l),.001*zlay(l)*r*200./g
c        WRITE(56,'(2e15.5)') dtsw(l),zlay(l)
      ENDDO


c.......................................................................
c  sorties GRADS-1D
c
c     (on utilise tmp2 pour ajouter le sol => nlayer -> nlayer+1)


c temp + tmep(0)=tsurf
      tmp2(0)=tsurf
      DO ilayer=1,nlayer
        tmp2(ilayer)=temp(ilayer)
      ENDDO

      g1d_tmp1='temp'
      g1d_tmp2='temperature avec tsurf'
      CALL writeg1d(1,nlayer+1,tmp2,g1d_tmp1,g1d_tmp2)

c dtlwcl + dtlwcl(0)=dtlwcl(1)
      tmp2(0)=dtlwcl(1)
      DO ilayer=1,nlayer
        tmp2(ilayer)=dtlwcl(ilayer)
      ENDDO

      g1d_tmp1='dtlwc'
      g1d_tmp2='cooling rate avec valeur sol fictive'
      CALL writeg1d(1,nlayer+1,tmp2,g1d_tmp1,g1d_tmp2)

c  sorties GRADS-1D
c
c.......................................................................

c.......................................................................
c  "fin pour GRADS-1D"
c

c zlay + zlay(0)= 0km (le sol)
      tmp2(0)=0.00001      !   pas 0 pour set zlog on
      DO ilayer=1,nlayer
        tmp2(ilayer)=zlay(ilayer)
      ENDDO

      CALL endg1d(1,nlayer+1,tmp2,1)
c     CALL endg1d(1,nlayer,zlay,1)
c     CALL endg1d(1,nlayer,logps10,ndt)

c
c  "fin pour GRADS-1D"
c.......................................................................
      END
*********************************************************************** *********************************************************************** *********************************************************************** *********************************************************************** *=*=*=*= 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)

      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)
c        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
c     write(14,'(3x,i5,1f10.4)') l,-h*log(s(llm))/kappa


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

      RETURN
      END