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(0,*)' 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(0,*)' TH=',TH,' QS=',QS,' TOLD=',TOLD(kth),' kth=',kth
            theold(kth) = th*exp(eliwv*qs/(cp*told(kth)))
          endif
        enddo
!         write(0,*)' 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