TABLEQ.f

!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      SUBROUTINE tableq(TTBLQ,RDP,RDTHE,PL,THL,STHE,THE0)
!     ******************************************************************
!     *                                                                *
!     *        GENERATE VALUES FOR FINER LOOK-UP TABLES USED           *
!     *                       IN CONVECTION                            *
!     *                                                                *
!     ******************************************************************
!
!
      implicit none
 
      integer,parameter :: ITB=152,jtb=440
      real,parameter :: THH=325.,ph=105000.                       &
     &, pq0=379.90516,a1=610.78,a2=17.2693882,a3=273.16,a4=35.86  &
     &, r=287.04,cp=1004.6,eliwv=2.683e6,eps=1.e-9
!
      real,dimension(JTB,ITB),intent(out) :: TTBLQ
      real,dimension(ITB),intent(out) :: THE0,STHE
      real,intent(in) :: PL,THL
      real,intent(out) :: RDP,RDTHE
!
       real TOLD  (JTB),THEOLD(JTB)                               &
     &, Y2T   (JTB),THENEW(JTB),APT   (JTB),AQT   (JTB),TNEW  (JTB)
!
       real PT,RDQ,DTH,DP,RDTH,TH,P,APE,DENOM,the0k, dthe,   &
            qs0k,sqsk,dqs,qs,theok,sthek
       integer KTHM,KPM,KTHM1,KPM1,KP,KMM,KTH
!
!--------------COARSE LOOK-UP TABLE FOR SATURATION POINT----------------
      kthm=jtb
      kpm=itb
      kthm1=kthm-1
      kpm1=kpm-1
!
      dth=(thh-thl)/real(kthm-1)
      dp =(ph -pl )/real(kpm -1)
!
      rdp=1./dp
      th=thl-dth
!--------------COARSE LOOK-UP TABLE FOR T(P) FROM CONSTANT THE----------
      p=pl-dp
              DO 550 kp=1,kpm
          p=p+dp
          th=thl-dth
          DO 560 kth=1,kthm
      th=th+dth
      ape=(100000./p)**(r/cp)
      qs=pq0/p*exp(a2*(th-a3*ape)/(th-a4*ape))
      told(kth)=th/ape
      theold(kth)=th*exp(eliwv*qs/(cp*told(kth)))
 560  CONTINUE
!
      the0k=theold(1)
      sthek=theold(kthm)-theold(1)
      theold(1   )=0.
      theold(kthm)=1.
!
          DO 570 kth=2,kthm1
      theold(kth)=(theold(kth)-the0k)/sthek
!
      IF((theold(kth)-theold(kth-1))<eps)     &
          theold(kth)=theold(kth-1)  +  eps
!
 570  CONTINUE
!
      the0(kp)=the0k
      sthe(kp)=sthek
!-----------------------------------------------------------------------
      thenew(1  )=0.
      thenew(kthm)=1.
      dthe=1./real(kthm-1)
      rdthe=1./dthe
!
          DO 580 kth=2,kthm1
      thenew(kth)=thenew(kth-1)+dthe
 580  CONTINUE
!
      y2t(1   )=0.
      y2t(kthm)=0.
!
      CALL spline(jtb,kthm,theold,told,y2t,kthm,thenew,tnew,apt,aqt)
!
          DO 590 kth=1,kthm
      ttblq(kth,kp)=tnew(kth)
 590  CONTINUE
!-----------------------------------------------------------------------
 550  CONTINUE
!
      RETURN
      END