GPVS.f

Go to the documentation of this file.

 
!-----------------------------------------------------------------------
      SUBROUTINE gpvs
!     ******************************************************************
 
!----------------------------------------------------------------------
      use svptbl_mod, only: nx, c1xpvs, c2xpvs, c1xpvs0, c2xpvs0, tbpvs, tbpvs0
!- - - - - - - - - - -- - - -- - - -- - - -- - - - - -- - - -- - - -
      implicit none
!
      real xmin,xmax,xinc,x,t
      integer jx
      real,external :: fpvsx,fpvsx0
!----------------------------------------------------------------------
      xmin=180.0
      xmax=330.0
      xinc=(xmax-xmin)/(nx-1)
      c1xpvs=1.-xmin/xinc
      c2xpvs=1./xinc
      c1xpvs0=1.-xmin/xinc
      c2xpvs0=1./xinc
!
      DO jx=1,nx
        x=xmin+(jx-1)*xinc
        t=x
        tbpvs(jx)=fpvsx(t)
        tbpvs0(jx)=fpvsx0(t)
      ENDDO
! 
      RETURN
      END
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
                           FUNCTION fpvs(T)
!-----------------------------------------------------------------------
      use svptbl_mod, only : nx,c1xpvs,c2xpvs,tbpvs
!
      implicit none
!
!      integer,parameter::NX=7501
!      real C1XPVS,C2XPVS,TBPVS(NX)
 
      real t
      real xj
      integer jx
      real fpvs
!-----------------------------------------------------------------------
      xj=min(max(c1xpvs+c2xpvs*t,1.),float(nx))
      jx=min(xj,nx-1.)
      fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx))
!
      RETURN
      END
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
 
                       FUNCTION fpvs0(T,NX,C1XPVS0,C2XPVS0,TBPVS0)
!-----------------------------------------------------------------------
!      use svptbl_mod, only : NX,C1XPVS0,C2XPVS0,TBPVS0
      implicit none
!
      integer nx
      real c1xpvs0,c2xpvs0,tbpvs0(nx)
     
      real t
      real xj1
      integer jx1
      real fpvs0
!-----------------------------------------------------------------------
      xj1=min(max(c1xpvs0+c2xpvs0*t,1.),float(nx))
      jx1=min(xj1,nx-1.)
      fpvs0=tbpvs0(jx1)+(xj1-jx1)*(tbpvs0(jx1+1)-tbpvs0(jx1))
!
      RETURN
      END
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
                         FUNCTION fpvsx(T)
!-----------------------------------------------------------------------
    implicit none
!
    real,PARAMETER :: cp=1.0046e+3,rd=287.04,rv=4.6150e+2,              &
            ttp=2.7316e+2,hvap=2.5000e+6,psat=6.1078e+2,                &
            cliq=4.1855e+3,cvap= 1.8460e+3,cice=2.1060e+3,hsub=2.8340e+6
    real,PARAMETER :: psatk=psat*1.e-3
    real,PARAMETER :: dldt=cvap-cliq,xa=-dldt/rv,xb=xa+hvap/(rv*ttp)
    real,PARAMETER :: dldti=cvap-cice,xai=-dldti/rv,xbi=xai+hsub/(rv*ttp)
    real :: tr, t
    real :: fpvsx
!-----------------------------------------------------------------------
    tr=ttp/t
!
    IF(t>=ttp)THEN
      fpvsx=psatk*(tr**xa)*exp(xb*(1.-tr))
    ELSE
      fpvsx=psatk*(tr**xai)*exp(xbi*(1.-tr))
    ENDIF
!
    RETURN
    END
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
                        FUNCTION fpvsx0(T)
!-----------------------------------------------------------------------
    implicit none
!
    real,PARAMETER :: cp=1.0046e+3,rd=287.04,rv=4.6150e+2,            &
              ttp=2.7316e+2,hvap=2.5000e+6,psat=6.1078e+2,            &
              cliq=4.1855e+3,cvap=1.8460e+3,cice=2.1060e+3,           &
              hsub=2.8340e+6
    real,PARAMETER :: psatk=psat*1.e-3
    real,PARAMETER :: dldt=cvap-cliq,xa=-dldt/rv,xb=xa+hvap/(rv*ttp)
    real,PARAMETER :: dldti=cvap-cice,xai=-dldt/rv,xbi=xa+hsub/(rv*ttp)
    real tr
    real t,fpvsx0
!-----------------------------------------------------------------------
    tr=ttp/t
    fpvsx0=psatk*(tr**xa)*exp(xb*(1.-tr))
!
    RETURN
    END