TABLE.f

!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
      SUBROUTINE table(PTBL,TTBL,PT                                  &
     &,                RDQ,RDTH,RDP,RDTHE,PL,THL,QS0,SQS,STHE,THE0)
!     ******************************************************************
!     *                                                                *
!     *    GENERATE VALUES FOR LOOK-UP TABLES USED IN CONVECTION       *
!     *                                                                *
!     ******************************************************************
!
       implicit none                                 ! Moorthi
!
       integer,parameter :: ITB=076, jtb=134
       real, parameter   :: THH=365.,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(ITB,JTB),intent(out) :: PTBL
       real,dimension(JTB,ITB),intent(out) :: TTBL
       real,dimension(JTB),intent(out)     :: QS0,SQS
       real,dimension(ITB),intent(out)     :: STHE,THE0
       real, intent(in)                    :: PT,THL
       real, intent(out)                   :: RDQ,RDTH,RDP,RDTHE,PL
       real                                                             &
     &         qsold(jtb), pold(jtb), qsnew(jtb)                      &
     &,        y2p(jtb), app(jtb), aqp(jtb), pnew(jtb)           &
     &,        told(jtb), theold(jtb)                                  &
     &,        y2t(jtb), thenew(jtb), apt(jtb), aqt(jtb), tnew(jtb)
!
       real    DTH,DP,TH,P,APE,DENOM,QS0K,SQSK,DQS,QS,THEOK,STHEK       &
     &,        the0k, dthe
       integer LTHM,KPM,KTHM1,KPM1,KP,KMM,KTHM,KTH
 
!--------------COARSE LOOK-UP TABLE FOR SATURATION POINT----------------
      kthm  = jtb
      kpm   = itb
      kthm1 = kthm-1
      kpm1  = kpm-1
! 
      pl = pt
!
      dth = (thh-thl) / real(kthm-1)
      dp  = (ph -pl ) / real(kpm -1)
!
      rdth = 1./dth
      rdp  = 1./dp
      rdq  = kpm-1
!
      th = thl - dth
!-----------------------------------------------------------------------
      DO kth=1,kthm
        th = th + dth
        p  = pl - dp
        DO kp=1,kpm
          p     = p + dp
          if (p <= 0.0) then
            pold(1)  = 0.0
            qsold(1) = 0.0
          else
            ape   = (100000./p)**(r/cp)
            denom = th - a4*ape
            IF (denom > eps) THEN
              qsold(kp) = pq0 / p*exp(a2*(th-a3*ape)/denom)
            ELSE
              qsold(kp) = 0.
            ENDIF
!           QSOLD(KP)=PQ0/P*EXP(A2*(TH-A3*APE)/(TH-A4*APE))
            pold(kp) = p
          endif
        enddo
!
        qs0k       = qsold(1)
        sqsk       = qsold(kpm) - qsold(1)
        qsold(1  ) = 0.
        qsold(kpm) = 1.
!
        DO kp=2,kpm1
          qsold(kp) = (qsold(kp)-qs0k)/sqsk
          IF((qsold(kp)-qsold(kp-1)) < eps) qsold(kp) = qsold(kp-1)+eps
        enddo
!
        qs0(kth) = qs0k
        sqs(kth) = sqsk
!-----------------------------------------------------------------------
        qsnew(1  ) = 0.
        qsnew(kpm) = 1.
        dqs = 1./real(kpm-1)
!
        DO kp=2,kpm1
          qsnew(kp) = qsnew(kp-1) + dqs
        enddo
!
        y2p(1   ) = 0.
        y2p(kpm ) = 0.
!
        CALL spline(jtb,kpm,qsold,pold,y2p,kpm,qsnew,pnew,app,aqp)
!
        DO kp=1,kpm
          ptbl(kp,kth) = pnew(kp)
        enddo
!-----------------------------------------------------------------------
      enddo
!--------------COARSE LOOK-UP TABLE FOR T(P) FROM CONSTANT THE----------
      p = pl - dp
!     write(*,*)' kpm=',kpm,' P=',P,' DP=',DP,' thl=',thl,' dth=',dth
      DO kp=1,kpm
        p  = p + dp
        th = thl - dth
        DO kth=1,kthm
          th    = th + dth
          if (p <= 0.0) then
            told(kth)   = th
            theold(kth) = th
          else
            ape   = (100000./p)**(r/cp)
            denom = th - a4*ape
            IF (denom > eps) THEN
              qs = pq0/p*exp(a2*(th-a3*ape)/denom)
            ELSE
              qs = 0.
            ENDIF
!           QS=PQ0/P*EXP(A2*(TH-A3*APE)/(TH-A4*APE))
            told(kth) = th / ape
!           write(*,*)' TH=',TH,' QS=',QS,' TOLD=',TOLD(kth),' kth=',kth
            theold(kth) = th*exp(eliwv*qs/(cp*told(kth)))
          endif
        enddo
!         write(*,*)' theold=',theold
!
        the0k = theold(1)
        sthek = theold(kthm) - theold(1)
        theold(1   ) = 0.
        theold(kthm) = 1.
! 
        DO kth=2,kthm1
          theold(kth)=(theold(kth)-the0k)/sthek
          IF((theold(kth)-theold(kth-1))<eps)      &
              theold(kth) = theold(kth-1) +  eps
        enddo
!
        the0(kp) = the0k
        sthe(kp) = sthek
!-----------------------------------------------------------------------
        thenew(1  )  = 0.
        thenew(kthm) = 1.
        dthe         = 1./real(kthm-1)
        rdthe        = 1./dthe
!
        DO kth=2,kthm1
         thenew(kth) = thenew(kth-1) + dthe
        enddo
!
        y2t(1   ) = 0.
        y2t(kthm) = 0.
!
        CALL spline(jtb,kthm,theold,told,y2t,kthm,thenew,tnew,apt,aqt)
!
        DO kth=1,kthm
          ttbl(kth,kp) = tnew(kth)
        enddo
!-----------------------------------------------------------------------
      enddo
!
      RETURN
      END