!**********************************************************************************************!
!                                        LAYER MODULE                                          !
!**********************************************************************************************!
module NNLayers
    implicit none

    integer,parameter,private   :: dp = kind(1.d0)

    !------------------------------------------------------
    ! Layer Class
    !------------------------------------------------------
    type :: Layer
        !---------- General Parameters -----------!
        character(len=20)       :: activation
        integer                 :: layerNumber
        integer                 :: isize

        !---------- Specific Parameters -----------!
        real(dp),allocatable    :: W(:,:), dW(:,:)
        real(dp),allocatable    :: B(:,:), dB(:,:)

        !----------- Input & Output --------------!
        real(dp),allocatable    :: Z(:,:)
        real(dp),allocatable    :: Y(:,:)
        real(dp),allocatable    :: dL(:,:)

        !---------------- Adam -------------------!
        real(dp),allocatable    :: Wm(:,:), Wv(:,:)
        real(dp),allocatable    :: Bm(:,:), Bv(:,:)

        !------------ Linked List ----------------!
        type(Layer),pointer     :: next,prev

        contains

        procedure               :: feed,back
        procedure               :: ZeroLayerGrads
        procedure               :: ApplyLayerGrads
        procedure               :: ApplyLayerAscent
        procedure               :: ApplyLayerAdam
        final                   :: LayerDestructor
    end type

    interface Layer
        procedure   :: LayerConstructor
    end interface

    contains

    !-------------------------!
    !       CONSTRUCTOR       !
    !-------------------------!
    function LayerConstructor(layerNumber,sizeIn,activation) result(self)
        implicit none

        integer,intent(in)          :: layerNumber
        integer,intent(in)          :: sizeIn
        character(len=*),intent(in) :: activation

        type(Layer) :: self

        self%layerNumber = layerNumber
        self%isize = sizeIn
        self%activation = activation

        self%next => null()
        self%prev => null()
    end function

    !-------------------------!
    !       DESTRUCTOR        !
    !-------------------------!
    subroutine LayerDestructor(self)
        implicit none

        type(Layer) :: self

        if (allocated(self%W)) then
            deallocate(self%W)
        end if
        if (allocated(self%dW)) then
            deallocate(self%dW)
        end if
        if (allocated(self%B)) then
            deallocate(self%B)
        end if
        if (allocated(self%dB)) then
            deallocate(self%dB)
        end if
        if (allocated(self%Z)) then
            deallocate(self%Z)
        end if
        if (allocated(self%Y)) then
            deallocate(self%Y)
        end if
        if (allocated(self%dL)) then
            deallocate(self%dL)
        end if
    end subroutine

    !------------------------------------------------------
    ! Feed Forward
    !------------------------------------------------------
    subroutine feed(self,X)
        use NNActiv
        implicit none

        class(Layer),intent(inout)  :: self
        real(dp),intent(in)         :: X(:,:)

        integer     :: i

        self%Y = matmul(self%W,X) + self%B
        self%Z = Activate(self%Y,self%activation)
    end subroutine

    !------------------------------------------------------
    ! Backpropagation
    !------------------------------------------------------
    subroutine back(self,X,dLdZ,skip_activation)
        use NNActiv
        implicit none

        class(Layer),intent(inout)  :: self
        real(dp),intent(in)         :: X(:,:)
        real(dp),intent(in)         :: dLdZ(:,:)
        logical,intent(in)          :: skip_activation

        real(dp)    :: dLdY(size(dLdZ,1),size(dLdZ,2))

        integer     :: k
        real        :: r

        ! Skip activation ?
        if (skip_activation .or. self%activation .eq. "none") then
            dLdY = dLdZ
        else
            dLdY = deactivate(dLdZ,self%Y,self%Z,self%activation)
        end if

        ! Backpropagate
        self%dB = self%dB + dLdY
        self%dW = self%dW + matmul(X,dLdY)
        self%dL = matmul(dLdY,self%W)
    end subroutine

    !------------------------------------------------------
    ! Zero Gradients
    !------------------------------------------------------
    subroutine ZeroLayerGrads(self)
        implicit none

        class(Layer),intent(inout)  :: self

        if (allocated(self%dW)) then
            self%dW = 0.0
        end if
        if (allocated(self%dB)) then
            self%dB = 0.0
        end if
    end subroutine

    !------------------------------------------------------
    ! Apply Gradients
    !------------------------------------------------------
    subroutine ApplyLayerGrads(self,lrate)
        implicit none

        class(Layer),intent(inout)  :: self
        real,intent(in)             :: lrate

        if (allocated(self%dW)) then
            self%W = self%W - lrate*transpose(self%dW)
        end if
        if (allocated(self%dB)) then
            self%B = self%B - lrate*transpose(self%dB)
        end if
    end subroutine

    subroutine ApplyLayerAscent(self,lrate)
        implicit none

        class(Layer),intent(inout)  :: self
        real,intent(in)             :: lrate

        if (allocated(self%dW)) then
            self%W = self%W + lrate*transpose(self%dW)
        end if
        if (allocated(self%dB)) then
            self%B = self%B + lrate*transpose(self%dB)
        end if
    end subroutine

    !------------------------------------------------------
    ! Adam
    !------------------------------------------------------
    subroutine ApplyLayerAdam(self,lrate,beta1,beta2,beta1n,beta2n)
        implicit none

        class(Layer),intent(inout)  :: self
        real,intent(in)             :: lrate
        real(dp),intent(in)         :: beta1,beta2,beta1n,beta2n

        real,parameter      :: esp = 1.0E-8
        real,parameter      :: tau = 10
        real                :: r
        integer             :: k

        real(dp),allocatable    :: bh(:,:),bv(:,:)
        real(dp),allocatable    :: wh(:,:),wv(:,:)

        if (allocated(self%dW)) then
            self%Wm = beta1*self%Wm + (1-beta1)*self%dW
            self%Wv = beta2*self%Wv + (1-beta2)*self%dW*self%dW

            allocate(wh(size(self%dW,1),size(self%dW,2)))
            allocate(wv(size(self%dW,1),size(self%dW,2)))

            wh = self%Wm/(1-beta1n)
            wv = self%Wv/(1-beta2n)

            ! Clipping
            wh = wh/(sqrt(wv)+esp)
            r = sqrt(sum(wh*wh))
            if (r > tau) then
                wh = tau*wh/r
            end if

            self%W = self%W - lrate*wh

            deallocate(wh,wv)
        end if

        ! BIAS
        if (allocated(self%dB)) then
            self%Bm = beta1*self%Bm + (1-beta1)*self%dB
            self%Bv = beta2*self%Bv + (1-beta2)*self%dB*self%dB

            allocate(bh(size(self%dB,1),size(self%dB,2)))
            allocate(bv(size(self%dB,1),size(self%dB,2)))

            bh = self%Bm/(1-beta1n)
            bv = self%Bv/(1-beta2n)

            ! Clipping
            bh = bh/(sqrt(bv)+esp)
            r = sqrt(sum(bh*bh))
            if (r > tau) then
                bh = tau*bh/r
            end if

            self%B(:,:) = self%B(:,:) - lrate*transpose(bh(:,:))

            deallocate(bh,bv)
        end if
    end subroutine

end module


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c ... file sphcom.f
c
c     this file must be loaded with all main program files
c     in spherepack.  it includes undocumented subroutines
c     called by some or all of main programs
c
      subroutine dnlfk (m,n,cp)
      implicit double precision (a-h,o-z)
c
c     cp requires n/2+1 double precision locations
c
      double precision cp,fnum,fden,fnmh,a1,b1,c1,cp2,fnnp1,fnmsq,fk,
     1       t1,t2,pm1,sc10,sc20,sc40
      dimension       cp(1)
      parameter (sc10=1024.d0)
      parameter (sc20=sc10*sc10)
      parameter (sc40=sc20*sc20)
c
      cp(1) = 0.d0
      ma = iabs(m)
      if(ma .gt. n) return
      if(n-1) 2,3,5
    2 cp(1) = dsqrt(2.d0)
      return
    3 if(ma .ne. 0) go to 4
      cp(1) = dsqrt(1.5d0)
      return
    4 cp(1) = dsqrt(.75d0)
      if(m .eq. -1) cp(1) = -cp(1)
      return
    5 if(mod(n+ma,2) .ne. 0) go to 10
      nmms2 = (n-ma)/2
      fnum = n+ma+1
      fnmh = n-ma+1
      pm1 = 1.d0
      go to 15
   10 nmms2 = (n-ma-1)/2
      fnum = n+ma+2
      fnmh = n-ma+2
      pm1 = -1.d0
c      t1 = 1.
c      t1 = 2.d0**(n-1)
c      t1 = 1.d0/t1
 15   t1 = 1.d0/sc20
      nex = 20
      fden = 2.d0
      if(nmms2 .lt. 1) go to 20
      do 18 i=1,nmms2
      t1 = fnum*t1/fden
      if(t1 .gt. sc20) then
      t1 = t1/sc40
      nex = nex+40
      end if
      fnum = fnum+2.d0
      fden = fden+2.d0
   18 continue
   20 t1 = t1/2.d0**(n-1-nex)
      if(mod(ma/2,2) .ne. 0) t1 = -t1
      t2 = 1.d0
      if(ma .eq. 0) go to 26
      do 25 i=1,ma
      t2 = fnmh*t2/(fnmh+pm1)
      fnmh = fnmh+2.d0
   25 continue
   26 cp2 = t1*dsqrt((n+.5d0)*t2)
      fnnp1 = n*(n+1)
      fnmsq = fnnp1-2.d0*ma*ma
      l = (n+1)/2
      if(mod(n,2) .eq. 0 .and. mod(ma,2) .eq. 0) l = l+1
      cp(l) = cp2
      if(m .ge. 0) go to 29
      if(mod(ma,2) .ne. 0) cp(l) = -cp(l)
   29 if(l .le. 1) return
      fk = n
      a1 = (fk-2.d0)*(fk-1.d0)-fnnp1
      b1 = 2.d0*(fk*fk-fnmsq)
      cp(l-1) = b1*cp(l)/a1
   30 l = l-1
      if(l .le. 1) return
      fk = fk-2.d0
      a1 = (fk-2.d0)*(fk-1.d0)-fnnp1
      b1 = -2.d0*(fk*fk-fnmsq)
      c1 = (fk+1.d0)*(fk+2.d0)-fnnp1
      cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
      go to 30
      end
      subroutine dnlft (m,n,theta,cp,pb)
      implicit double precision (a-h,o-z)
      double precision cp(*),pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(m,2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = .5d0*cp(1)
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb+cp(k+1)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.d0
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.d0
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb+cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.d0
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end
      subroutine dnlftd (m,n,theta,cp,pb)
      implicit double precision (a-h,o-z)
c
c     computes the derivative of pmn(theta) with respect to theta
c
      dimension cp(1)
      double precision cp,pb,theta,cdt,sdt,cth,sth,chh
      cdt = dcos(theta+theta)
      sdt = dsin(theta+theta)
      nmod=mod(n,2)
      mmod=mod(abs(m),2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo=n/2
      pb = 0.d0
      if(n .eq. 0) return
      cth = cdt
      sth = sdt
      do 170 k=1,kdo
c     pb = pb+cp(k+1)*dcos(2*k*theta)
      pb = pb-2.d0*k*cp(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  170 continue
      return
c
c     n even, m odd
c
    4 kdo = n/2
      pb = 0.d0
      cth = cdt
      sth = sdt
      do 180 k=1,kdo
c     pb = pb+cp(k)*dsin(2*k*theta)
      pb = pb+2.d0*k*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  180 continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      pb = 0.d0
      cth = dcos(theta)
      sth = dsin(theta)
      do 190 k=1,kdo
c     pb = pb+cp(k)*dcos((2*k-1)*theta)
      pb = pb-(2.d0*k-1)*cp(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  190 continue
      return
c
c     n odd, m odd
c
   14 kdo = (n+1)/2
      pb = 0.d0
      cth = dcos(theta)
      sth = dsin(theta)
      do 200 k=1,kdo
c     pb = pb+cp(k)*dsin((2*k-1)*theta)
      pb = pb+(2.d0*k-1)*cp(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  200 continue
      return
      end
      subroutine legin(mode,l,nlat,m,w,pmn,km,km0,km1,km2)
      implicit double precision (a-h,o-z)
c     this subroutine computes legendre polynomials for n=m,...,l-1
c     and  i=1,...,late (late=((nlat+mod(nlat,2))/2)gaussian grid
c     in pmn(n+1,i,km) using swarztrauber's recursion formula.
c     the vector w contains quantities precomputed in shigc.
c     legin must be called in the order m=0,1,...,l-1
c     (e.g., if m=10 is sought it must be preceded by calls with
c     m=0,1,2,...,9 in that order)
      dimension w(1),pmn(1)
c     set size of pole to equator gaussian grid
      late = (nlat+mod(nlat,2))/2
c     partition w (set pointers for p0n,p1n,abel,bbel,cbel,pmn)
      i1 = 1+nlat
      i2 = i1+nlat*late
      i3 = i2+nlat*late
      i4 = i3+(2*nlat-l)*(l-1)/2
      i5 = i4+(2*nlat-l)*(l-1)/2
      call legin1(mode,l,nlat,late,m,w(i1),w(i2),w(i3),w(i4),
     1            w(i5),pmn,km,km0,km1,km2)
      return
      end
      subroutine legin1(mode,l,nlat,late,m,p0n,p1n,abel,bbel,cbel,
     1                  pmn,km,km0,km1,km2)
      implicit double precision (a-h,o-z)
      dimension p0n(nlat,late),p1n(nlat,late)
      dimension abel(1),bbel(1),cbel(1),pmn(nlat,late,3)
c     define index function used in storing triangular
c     arrays for recursion coefficients (functions of (m,n))
c     for 2.le.m.le.n-1 and 2.le.n.le.l-1
      indx(m,n) = (n-1)*(n-2)/2+m-1
c     for l.le.n.le.nlat and 2.le.m.le.l
      imndx(m,n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1

c     set do loop indices for full or half sphere
      ms = m+1
      ninc = 1
      if (mode.eq.1) then
c     only compute pmn for n-m odd
      ms = m+2
      ninc = 2
      else if (mode.eq.2) then
c     only compute pmn for n-m even
      ms = m+1
      ninc = 2
      end if

      if (m.gt.1) then
      do 100 np1=ms,nlat,ninc
      n = np1-1
      imn = indx(m,n)
      if (n.ge.l) imn = imndx(m,n)
      do 100 i=1,late
      pmn(np1,i,km0) = abel(imn)*pmn(n-1,i,km2)
     1            +bbel(imn)*pmn(n-1,i,km0)
     2            -cbel(imn)*pmn(np1,i,km2)
  100 continue

      else if (m.eq.0) then
      do 101 np1=ms,nlat,ninc
      do 101 i=1,late
      pmn(np1,i,km0) = p0n(np1,i)
  101 continue

      else if (m.eq.1) then
      do 102 np1=ms,nlat,ninc
      do 102 i=1,late
      pmn(np1,i,km0) = p1n(np1,i)
  102 continue
      end if

c     permute column indices
c     km0,km1,km2 store m,m-1,m-2 columns
      kmt = km0
      km0 = km2
      km2 = km1
      km1 = kmt
c     set current m index in output param km
      km = kmt
      return
      end

c$$$      subroutine zfin (isym,nlat,nlon,m,z,i3,wzfin)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       z(1)        ,wzfin(1)
c$$$      imid = (nlat+1)/2
c$$$      lim = nlat*imid
c$$$      mmax = min0(nlat,nlon/2+1)
c$$$      labc = ((mmax-2)*(nlat+nlat-mmax-1))/2
c$$$      iw1 = lim+1
c$$$      iw2 = iw1+lim
c$$$      iw3 = iw2+labc
c$$$      iw4 = iw3+labc
c$$$c
c$$$c     the length of wzfin is 2*lim+3*labc
c$$$c
c$$$      call zfin1 (isym,nlat,m,z,imid,i3,wzfin,wzfin(iw1),wzfin(iw2),
c$$$     1            wzfin(iw3),wzfin(iw4))
c$$$      return
c$$$      end
c$$$      subroutine zfin1 (isym,nlat,m,z,imid,i3,zz,z1,a,b,c)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       z(imid,nlat,3),zz(imid,1),z1(imid,1),
c$$$     1                a(1),b(1),c(1)
c$$$      save i1,i2
c$$$      ihold = i1
c$$$      i1 = i2
c$$$      i2 = i3
c$$$      i3 = ihold
c$$$      if(m-1)25,30,35
c$$$   25 i1 = 1
c$$$      i2 = 2
c$$$      i3 = 3
c$$$      do 45 np1=1,nlat
c$$$      do 45 i=1,imid
c$$$      z(i,np1,i3) = zz(i,np1)
c$$$   45 continue
c$$$      return
c$$$   30 do 50 np1=2,nlat
c$$$      do 50 i=1,imid
c$$$      z(i,np1,i3) = z1(i,np1)
c$$$   50 continue
c$$$      return
c$$$   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
c$$$      if(isym .eq. 1) go to 36
c$$$      do 85 i=1,imid
c$$$      z(i,m+1,i3) = a(ns)*z(i,m-1,i1)-c(ns)*z(i,m+1,i1)
c$$$   85 continue
c$$$   36 if(m .eq. nlat-1) return
c$$$      if(isym .eq. 2) go to 71
c$$$      ns = ns+1
c$$$      do 70 i=1,imid
c$$$      z(i,m+2,i3) = a(ns)*z(i,m,i1)-c(ns)*z(i,m+2,i1)
c$$$   70 continue
c$$$   71 nstrt = m+3
c$$$      if(isym .eq. 1) nstrt = m+4
c$$$      if(nstrt .gt. nlat) go to 80
c$$$      nstp = 2
c$$$      if(isym .eq. 0) nstp = 1
c$$$      do 75 np1=nstrt,nlat,nstp
c$$$      ns = ns+nstp
c$$$      do 75 i=1,imid
c$$$      z(i,np1,i3) = a(ns)*z(i,np1-2,i1)+b(ns)*z(i,np1-2,i3)
c$$$     1                              -c(ns)*z(i,np1,i1)
c$$$   75 continue
c$$$   80 return
c$$$      end
      subroutine zfinit (nlat,nlon,wzfin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wzfin(*)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wzfin is 3*((l-3)*l+2)/2 + 2*l*imid
c     the length of dwork is nlat+2
c
      call zfini1 (nlat,nlon,imid,wzfin,wzfin(iw1),dwork,
     1                                       dwork(nlat/2+1))
      return
      end
      subroutine zfini1 (nlat,nlon,imid,z,abc,cz,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations
c     where mmax = min0(nlat,nlon/2+1)
c     cz and work must each have nlat+1 locations
c
      dimension z(imid,nlat,2),abc(1)
      double precision pi,dt,th,zh,cz(*),work(*)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      do 160 mp1=1,2
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dnzfk(nlat,m,n,cz,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dnzft(nlat,m,n,th,cz,zh)
      z(i,np1,mp1) = zh
  165 continue
      z(1,np1,mp1) = .5d0*z(1,np1,mp1)
  160 continue
      call rabcp(nlat,nlon,abc)
      return
      end
      subroutine dnzfk(nlat,m,n,cz,work)
      implicit double precision (a-h,o-z)
c
c     dnzfk computes the coefficients in the trigonometric
c     expansion of the z functions that are used in spherical
c     harmonic analysis.
c
      dimension  cz(1),work(1)
c
c     cz and work must both have nlat/2+1 locations
c
      double precision sum,sc1,t1,t2,work,cz
      lc = (nlat+1)/2
      sc1 = 2.d0/dfloat(nlat-1)
      call dnlfk(m,n,work)
      nmod = mod(n,2)
      mmod = mod(m,2)
      if(nmod)1,1,2
1     if(mmod)3,3,4
c
c     n even, m even
c
3     kdo = n/2+1
      do 5 idx=1,lc
      i = idx+idx-2
      sum = work(1)/(1.d0-i*i)
      if(kdo.lt.2) go to 29
      do 6 kp1=2,kdo
      k = kp1-1
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
8     sum = sum+work(kp1)*(t1+t2)/(t1*t2)
6     continue
29    cz(idx) = sc1*sum
5     continue
      return
c
c     n even, m odd
c
4     kdo = n/2
      do 9 idx=1,lc
      i = idx+idx-2
      sum = 0.d0
      do 101 k=1,kdo
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
12    sum=sum+work(k)*(t1-t2)/(t1*t2)
101   continue
      cz(idx) = sc1*sum
9     continue
      return
2     if(mmod)13,13,14
c
c     n odd, m even
c
13    kdo = (n+1)/2
      do 15 idx=1,lc
      i = idx+idx-1
      sum = 0.d0
      do 16 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
18    sum=sum+work(k)*(t1+t2)/(t1*t2)
16    continue
      cz(idx)=sc1*sum
15    continue
      return
c
c     n odd, m odd
c
14    kdo = (n+1)/2
      do 19 idx=1,lc
      i = idx+idx-3
      sum=0.d0
      do 20 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
22    sum=sum+work(k)*(t1-t2)/(t1*t2)
20    continue
      cz(idx)=sc1*sum
19    continue
      return
      end
      subroutine dnzft(nlat,m,n,th,cz,zh)
      implicit double precision (a-h,o-z)
      dimension cz(1)
      double precision cz,zh,th,cdt,sdt,cth,sth,chh
      zh = 0.d0
      cdt = dcos(th+th)
      sdt = dsin(th+th)
      lmod = mod(nlat,2)
      mmod = mod(m,2)
      nmod = mod(n,2)
      if(lmod)20,20,10
   10 lc = (nlat+1)/2
      lq = lc-1
      ls = lc-2
      if(nmod)1,1,2
    1 if(mmod)3,3,4
c
c     nlat odd n even m even
c
    3 zh = .5d0*(cz(1)+cz(lc)*dcos(2*lq*th))
      cth = cdt
      sth = sdt
      do 201 k=2,lq
c     zh = zh+cz(k)*dcos(2*(k-1)*th)
      zh = zh+cz(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  201 continue
      return
c
c     nlat odd n even m odd
c
    4 cth = cdt
      sth = sdt
      do 202 k=1,ls
c     zh = zh+cz(k+1)*dsin(2*k*th)
      zh = zh+cz(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  202 continue
      return
c
c     nlat odd n odd, m even
c
    2 if(mmod)5,5,6
    5 cth = dcos(th)
      sth = dsin(th)
      do 203 k=1,lq
c     zh = zh+cz(k)*dcos((2*k-1)*th)
      zh = zh+cz(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  203 continue
      return
c
c     nlat odd n odd m odd
c
    6 cth = dcos(th)
      sth = dsin(th)
      do 204 k=1,lq
c     zh = zh+cz(k+1)*dsin((2*k-1)*th)
      zh = zh+cz(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  204 continue
      return
   20 lc = nlat/2
      lq = lc-1
      if(nmod)30,30,80
   30 if(mmod)40,40,60
c
c     nlat even n even m even
c
   40 zh = .5d0*cz(1)
      cth = cdt
      sth = sdt
      do 50 k=2,lc
c     zh = zh+cz(k)*dcos(2*(k-1)*th)
      zh = zh+cz(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   50 continue
      return
c
c     nlat even n even m odd
c
   60 cth = cdt
      sth = sdt
      do 70 k=1,lq
c     zh = zh+cz(k+1)*dsin(2*k*th)
      zh = zh+cz(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   70 continue
      return
c
c     nlat even n odd m even
c
   80 if(mmod)90,90,110
   90 zh = .5d0*cz(lc)*dcos((nlat-1)*th)
      cth = dcos(th)
      sth = dsin(th)
      do 100 k=1,lq
c     zh = zh+cz(k)*dcos((2*k-1)*th)
      zh = zh+cz(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  100 continue
      return
c
c     nlat even n odd m odd
c
  110 cth = dcos(th)
      sth = dsin(th)
      do 120 k=1,lq
c     zh = zh+cz(k+1)*dsin((2*k-1)*th)
      zh = zh+cz(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
  120 continue
      return
      end
c$$$      subroutine alin (isym,nlat,nlon,m,p,i3,walin)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       p(1)        ,walin(1)
c$$$      imid = (nlat+1)/2
c$$$      lim = nlat*imid
c$$$      mmax = min0(nlat,nlon/2+1)
c$$$      labc = ((mmax-2)*(nlat+nlat-mmax-1))/2
c$$$      iw1 = lim+1
c$$$      iw2 = iw1+lim
c$$$      iw3 = iw2+labc
c$$$      iw4 = iw3+labc
c$$$c
c$$$c     the length of walin is ((5*l-7)*l+6)/2
c$$$c
c$$$      call alin1 (isym,nlat,m,p,imid,i3,walin,walin(iw1),walin(iw2),
c$$$     1            walin(iw3),walin(iw4))
c$$$      return
c$$$      end
c$$$      subroutine alin1 (isym,nlat,m,p,imid,i3,pz,p1,a,b,c)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       p(imid,nlat,3),pz(imid,1),p1(imid,1),
c$$$     1                a(1),b(1),c(1)
c$$$      save i1,i2
c$$$      ihold = i1
c$$$      i1 = i2
c$$$      i2 = i3
c$$$      i3 = ihold
c$$$      if(m-1)25,30,35
c$$$   25 i1 = 1
c$$$      i2 = 2
c$$$      i3 = 3
c$$$      do 45 np1=1,nlat
c$$$      do 45 i=1,imid
c$$$      p(i,np1,i3) = pz(i,np1)
c$$$   45 continue
c$$$      return
c$$$   30 do 50 np1=2,nlat
c$$$      do 50 i=1,imid
c$$$      p(i,np1,i3) = p1(i,np1)
c$$$   50 continue
c$$$      return
c$$$   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
c$$$      if(isym .eq. 1) go to 36
c$$$      do 85 i=1,imid
c$$$      p(i,m+1,i3) = a(ns)*p(i,m-1,i1)-c(ns)*p(i,m+1,i1)
c$$$   85 continue
c$$$   36 if(m .eq. nlat-1) return
c$$$      if(isym .eq. 2) go to 71
c$$$      ns = ns+1
c$$$      do 70 i=1,imid
c$$$      p(i,m+2,i3) = a(ns)*p(i,m,i1)-c(ns)*p(i,m+2,i1)
c$$$   70 continue
c$$$   71 nstrt = m+3
c$$$      if(isym .eq. 1) nstrt = m+4
c$$$      if(nstrt .gt. nlat) go to 80
c$$$      nstp = 2
c$$$      if(isym .eq. 0) nstp = 1
c$$$      do 75 np1=nstrt,nlat,nstp
c$$$      ns = ns+nstp
c$$$      do 75 i=1,imid
c$$$      p(i,np1,i3) = a(ns)*p(i,np1-2,i1)+b(ns)*p(i,np1-2,i3)
c$$$     1                              -c(ns)*p(i,np1,i1)
c$$$   75 continue
c$$$   80 return
c$$$      end
      subroutine alinit (nlat,nlon,walin,dwork)
      implicit double precision (a-h,o-z)
      dimension       walin(*)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of walin is 3*((l-3)*l+2)/2 + 2*l*imid
c     the length of work is nlat+1
c
      call alini1 (nlat,nlon,imid,walin,walin(iw1),dwork)
      return
      end
      subroutine alini1 (nlat,nlon,imid,p,abc,cp)
      implicit double precision (a-h,o-z)
      dimension p(imid,nlat,2),abc(1),cp(1)
      double precision pi,dt,th,cp,ph
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      do 160 mp1=1,2
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dnlfk (m,n,cp)
      do 160 i=1,imid
      th = (i-1)*dt
      call dnlft (m,n,th,cp,ph)
      p(i,np1,mp1) = ph
  160 continue
      call rabcp(nlat,nlon,abc)
      return
      end
      subroutine rabcp(nlat,nlon,abc)
      implicit double precision (a-h,o-z)
c
c     subroutine rabcp computes the coefficients in the recurrence
c     relation for the associated legendre fuctions. array abc
c     must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations.
c
      dimension abc(1)
      mmax = min0(nlat,nlon/2+1)
      labc = ((mmax-2)*(nlat+nlat-mmax-1))/2
      iw1 = labc+1
      iw2 = iw1+labc
      call rabcp1(nlat,nlon,abc,abc(iw1),abc(iw2))
      return
      end
      subroutine rabcp1(nlat,nlon,a,b,c)
      implicit double precision (a-h,o-z)
c
c     coefficients a, b, and c for computing pbar(m,n,theta) are
c     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
c
      dimension a(1),b(1),c(1)
      mmax = min0(nlat,nlon/2+1)
      do 215 mp1=3,mmax
      m = mp1-1
      ns = ((m-2)*(nlat+nlat-m-1))/2+1
      fm = dfloat(m)
      tm = fm+fm
      temp = tm*(tm-1.d0)
      a(ns) = dsqrt((tm+1.d0)*(tm-2.d0)/temp)
      c(ns) = dsqrt(2.d0/temp)
      if(m .eq. nlat-1) go to 215
      ns = ns+1
      temp = tm*(tm+1.d0)
      a(ns) = dsqrt((tm+3.d0)*(tm-2.d0)/temp)
      c(ns) = dsqrt(6.d0/temp)
      mp3 = m+3
      if(mp3 .gt. nlat) go to 215
      do 210 np1=mp3,nlat
      n = np1-1
      ns = ns+1
      fn = dfloat(n)
      tn = fn+fn
      cn = (tn+1.d0)/(tn-3.d0)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.d0)
      a(ns) = dsqrt(cn*(fnpm-3.d0)*(fnpm-2.d0)/temp)
      b(ns) = dsqrt(cn*fnmm*(fnmm-1.d0)/temp)
      c(ns) = dsqrt((fnmm+1.d0)*(fnmm+2.d0)/temp)
  210 continue
  215 continue
      return
      end
c$$$      subroutine sea1(nlat,nlon,imid,z,idz,zin,wzfin,dwork)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension z(idz,*),zin(imid,nlat,3),wzfin(*)
c$$$      double precision dwork(*)
c$$$      call zfinit(nlat,nlon,wzfin,dwork)
c$$$      mmax = min0(nlat,nlon/2+1)
c$$$      do 33 mp1=1,mmax
c$$$      m = mp1-1
c$$$      call zfin (0,nlat,nlon,m,zin,i3,wzfin)
c$$$      do 33 np1=mp1,nlat
c$$$      mn = m*(nlat-1)-(m*(m-1))/2+np1
c$$$      do 33 i=1,imid
c$$$      z(mn,i) = zin(i,np1,i3)
c$$$   33 continue
c$$$      return
c$$$      end
c$$$      subroutine ses1(nlat,nlon,imid,p,pin,walin,dwork)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension p(imid,*),pin(imid,nlat,3),walin(*)
c$$$      double precision dwork(*)
c$$$      call alinit (nlat,nlon,walin,dwork)
c$$$      mmax = min0(nlat,nlon/2+1)
c$$$      do 10 mp1=1,mmax
c$$$      m = mp1-1
c$$$      call alin(0,nlat,nlon,m,pin,i3,walin)
c$$$      do 10 np1=mp1,nlat
c$$$      mn = m*(nlat-1)-(m*(m-1))/2+np1
c$$$      do 10 i=1,imid
c$$$      p(i,mn) = pin(i,np1,i3)
c$$$   10 continue
c$$$      return
c$$$      end
      subroutine zvinit (nlat,nlon,wzvin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wzvin(1)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wzvin is
c         2*nlat*imid +3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     the length of dwork is nlat+2
c
      call zvini1 (nlat,nlon,imid,wzvin,wzvin(iw1),dwork,
     1                                    dwork(nlat/2+2))
      return
      end
      subroutine zvini1 (nlat,nlon,imid,zv,abc,czv,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     czv and work must each have nlat/2+1  locations
c
      dimension zv(imid,nlat,2),abc(1)
      double precision pi,dt,czv(1),zvh,th,work(1)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(2,nlat,(nlon+1)/2)
      do 160 mp1=1,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dzvk(nlat,m,n,czv,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dzvt(nlat,m,n,th,czv,zvh)
      zv(i,np1,mp1) = zvh
  165 continue
      zv(1,np1,mp1) = .5d0*zv(1,np1,mp1)
  160 continue
      call rabcv(nlat,nlon,abc)
      return
      end
      subroutine zwinit (nlat,nlon,wzwin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wzwin(1)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wzvin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of dwork is nlat+2
c
      call zwini1 (nlat,nlon,imid,wzwin,wzwin(iw1),dwork,
     1                                        dwork(nlat/2+2))
      return
      end
      subroutine zwini1 (nlat,nlon,imid,zw,abc,czw,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     czw and work must each have nlat+1 locations
c
      dimension zw(imid,nlat,2),abc(1)
      double precision  pi,dt,czw(1),zwh,th,work(1)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(3,nlat,(nlon+1)/2)
      if(mdo .lt. 2) return
      do 160 mp1=2,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dzwk(nlat,m,n,czw,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dzwt(nlat,m,n,th,czw,zwh)
      zw(i,np1,m) = zwh
  165 continue
      zw(1,np1,m) = .5d0*zw(1,np1,m)
  160 continue
      call rabcw(nlat,nlon,abc)
      return
      end
c$$$      subroutine zvin (ityp,nlat,nlon,m,zv,i3,wzvin)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       zv(1)        ,wzvin(1)
c$$$      imid = (nlat+1)/2
c$$$      lim = nlat*imid
c$$$      mmax = min0(nlat,(nlon+1)/2)
c$$$      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c$$$      iw1 = lim+1
c$$$      iw2 = iw1+lim
c$$$      iw3 = iw2+labc
c$$$      iw4 = iw3+labc
c$$$c
c$$$c     the length of wzvin is 2*lim+3*labc
c$$$c
c$$$      call zvin1 (ityp,nlat,m,zv,imid,i3,wzvin,wzvin(iw1),wzvin(iw2),
c$$$     1            wzvin(iw3),wzvin(iw4))
c$$$      return
c$$$      end
c$$$      subroutine zvin1 (ityp,nlat,m,zv,imid,i3,zvz,zv1,a,b,c)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       zv(imid,nlat,3),zvz(imid,1),zv1(imid,1),
c$$$     1                a(1),b(1),c(1)
c$$$      save i1,i2
c$$$      ihold = i1
c$$$      i1 = i2
c$$$      i2 = i3
c$$$      i3 = ihold
c$$$      if(m-1)25,30,35
c$$$   25 i1 = 1
c$$$      i2 = 2
c$$$      i3 = 3
c$$$      do 45 np1=1,nlat
c$$$      do 45 i=1,imid
c$$$      zv(i,np1,i3) = zvz(i,np1)
c$$$   45 continue
c$$$      return
c$$$   30 do 50 np1=2,nlat
c$$$      do 50 i=1,imid
c$$$      zv(i,np1,i3) = zv1(i,np1)
c$$$   50 continue
c$$$      return
c$$$   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
c$$$      if(ityp .eq. 1) go to 36
c$$$      do 85 i=1,imid
c$$$      zv(i,m+1,i3) = a(ns)*zv(i,m-1,i1)-c(ns)*zv(i,m+1,i1)
c$$$   85 continue
c$$$   36 if(m .eq. nlat-1) return
c$$$      if(ityp .eq. 2) go to 71
c$$$      ns = ns+1
c$$$      do 70 i=1,imid
c$$$      zv(i,m+2,i3) = a(ns)*zv(i,m,i1)-c(ns)*zv(i,m+2,i1)
c$$$   70 continue
c$$$   71 nstrt = m+3
c$$$      if(ityp .eq. 1) nstrt = m+4
c$$$      if(nstrt .gt. nlat) go to 80
c$$$      nstp = 2
c$$$      if(ityp .eq. 0) nstp = 1
c$$$      do 75 np1=nstrt,nlat,nstp
c$$$      ns = ns+nstp
c$$$      do 75 i=1,imid
c$$$      zv(i,np1,i3) = a(ns)*zv(i,np1-2,i1)+b(ns)*zv(i,np1-2,i3)
c$$$     1                              -c(ns)*zv(i,np1,i1)
c$$$   75 continue
c$$$   80 return
c$$$      end
c$$$      subroutine zwin (ityp,nlat,nlon,m,zw,i3,wzwin)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       zw(1)        ,wzwin(1)
c$$$      imid = (nlat+1)/2
c$$$      lim = nlat*imid
c$$$      mmax = min0(nlat,(nlon+1)/2)
c$$$      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c$$$      iw1 = lim+1
c$$$      iw2 = iw1+lim
c$$$      iw3 = iw2+labc
c$$$      iw4 = iw3+labc
c$$$c
c$$$c     the length of wzwin is 2*lim+3*labc
c$$$c
c$$$      call zwin1 (ityp,nlat,m,zw,imid,i3,wzwin,wzwin(iw1),wzwin(iw2),
c$$$     1            wzwin(iw3),wzwin(iw4))
c$$$      return
c$$$      end
c$$$      subroutine zwin1 (ityp,nlat,m,zw,imid,i3,zw1,zw2,a,b,c)
c$$$      implicit double precision (a-h,o-z)
c$$$      dimension       zw(imid,nlat,3),zw1(imid,1),zw2(imid,1),
c$$$     1                a(1),b(1),c(1)
c$$$      save i1,i2
c$$$      ihold = i1
c$$$      i1 = i2
c$$$      i2 = i3
c$$$      i3 = ihold
c$$$      if(m-2)25,30,35
c$$$   25 i1 = 1
c$$$      i2 = 2
c$$$      i3 = 3
c$$$      do 45 np1=2,nlat
c$$$      do 45 i=1,imid
c$$$      zw(i,np1,i3) = zw1(i,np1)
c$$$   45 continue
c$$$      return
c$$$   30 do 50 np1=3,nlat
c$$$      do 50 i=1,imid
c$$$      zw(i,np1,i3) = zw2(i,np1)
c$$$   50 continue
c$$$      return
c$$$   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
c$$$      if(ityp .eq. 1) go to 36
c$$$      do 85 i=1,imid
c$$$      zw(i,m+1,i3) = a(ns)*zw(i,m-1,i1)-c(ns)*zw(i,m+1,i1)
c$$$   85 continue
c$$$   36 if(m .eq. nlat-1) return
c$$$      if(ityp .eq. 2) go to 71
c$$$      ns = ns+1
c$$$      do 70 i=1,imid
c$$$      zw(i,m+2,i3) = a(ns)*zw(i,m,i1)-c(ns)*zw(i,m+2,i1)
c$$$   70 continue
c$$$   71 nstrt = m+3
c$$$      if(ityp .eq. 1) nstrt = m+4
c$$$      if(nstrt .gt. nlat) go to 80
c$$$      nstp = 2
c$$$      if(ityp .eq. 0) nstp = 1
c$$$      do 75 np1=nstrt,nlat,nstp
c$$$      ns = ns+nstp
c$$$      do 75 i=1,imid
c$$$      zw(i,np1,i3) = a(ns)*zw(i,np1-2,i1)+b(ns)*zw(i,np1-2,i3)
c$$$     1                              -c(ns)*zw(i,np1,i1)
c$$$   75 continue
c$$$   80 return
c$$$      end
      subroutine vbinit (nlat,nlon,wvbin,dwork)
      implicit double precision (a-h,o-z)
      dimension wvbin(1)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of dwork is nlat+2
c
      call vbini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork,
     1                                       dwork(nlat/2+2))
      return
      end
      subroutine vbini1 (nlat,nlon,imid,vb,abc,cvb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cvb and work must each have nlat+1 locations
c
      dimension vb(imid,nlat,2),abc(1)
      double precision pi,dt,cvb(1),th,vbh,work(1)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(2,nlat,(nlon+1)/2)
      do 160 mp1=1,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dvbk(m,n,cvb,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dvbt(m,n,th,cvb,vbh)
      vb(i,np1,mp1) = vbh
  165 continue
  160 continue
      call rabcv(nlat,nlon,abc)
      return
      end
      subroutine wbinit (nlat,nlon,wwbin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wwbin(1)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of dwork is nlat+2
c
      call wbini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork,
     1                                        dwork(nlat/2+2))
      return
      end
      subroutine wbini1 (nlat,nlon,imid,wb,abc,cwb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cwb and work must each have nlat/2+1 locations
c
      dimension wb(imid,nlat,2),abc(1)
      double precision pi,dt,cwb(1),wbh,th,work(1)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(3,nlat,(nlon+1)/2)
      if(mdo .lt. 2) return
      do 160 mp1=2,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dwbk(m,n,cwb,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dwbt(m,n,th,cwb,wbh)
      wb(i,np1,m) = wbh
  165 continue
  160 continue
      call rabcw(nlat,nlon,abc)
      return
      end
      subroutine vbin (ityp,nlat,nlon,m,vb,i3,wvbin,i1,i2)
      implicit double precision (a-h,o-z)
      dimension       vb(1)        ,wvbin(1)
      imid = (nlat+1)/2
      lim = nlat*imid
      mmax = min0(nlat,(nlon+1)/2)
      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      iw1 = lim+1
      iw2 = iw1+lim
      iw3 = iw2+labc
      iw4 = iw3+labc
c
c     the length of wvbin is 2*lim+3*labc
c
      call vbin1 (ityp,nlat,m,vb,imid,i3,wvbin,wvbin(iw1),wvbin(iw2),
     1            wvbin(iw3),wvbin(iw4),i1,i2)
      return
      end
      subroutine vbin1 (ityp,nlat,m,vb,imid,i3,vbz,vb1,a,b,c,i1,i2)
      implicit double precision (a-h,o-z)
      dimension       vb(imid,nlat,3),vbz(imid,1),vb1(imid,1),
     1                a(1),b(1),c(1)
      ihold = i1
      i1 = i2
      i2 = i3
      i3 = ihold
      if(m-1)25,30,35
   25 i1 = 1
      i2 = 2
      i3 = 3
      do 45 np1=1,nlat
      do 45 i=1,imid
      vb(i,np1,i3) = vbz(i,np1)
   45 continue
      return
   30 do 50 np1=2,nlat
      do 50 i=1,imid
      vb(i,np1,i3) = vb1(i,np1)
   50 continue
      return
   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
      if(ityp .eq. 1) go to 36
      do 85 i=1,imid
      vb(i,m+1,i3) = a(ns)*vb(i,m-1,i1)-c(ns)*vb(i,m+1,i1)
   85 continue
   36 if(m .eq. nlat-1) return
      if(ityp .eq. 2) go to 71
      ns = ns+1
      do 70 i=1,imid
      vb(i,m+2,i3) = a(ns)*vb(i,m,i1)-c(ns)*vb(i,m+2,i1)
   70 continue
   71 nstrt = m+3
      if(ityp .eq. 1) nstrt = m+4
      if(nstrt .gt. nlat) go to 80
      nstp = 2
      if(ityp .eq. 0) nstp = 1
      do 75 np1=nstrt,nlat,nstp
      ns = ns+nstp
      do 75 i=1,imid
      vb(i,np1,i3) = a(ns)*vb(i,np1-2,i1)+b(ns)*vb(i,np1-2,i3)
     1                              -c(ns)*vb(i,np1,i1)
   75 continue
   80 return
      end
      subroutine wbin (ityp,nlat,nlon,m,wb,i3,wwbin,i1,i2)
      implicit double precision (a-h,o-z)
      dimension       wb(1)        ,wwbin(1)
      imid = (nlat+1)/2
      lim = nlat*imid
      mmax = min0(nlat,(nlon+1)/2)
      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      iw1 = lim+1
      iw2 = iw1+lim
      iw3 = iw2+labc
      iw4 = iw3+labc
c
c     the length of wwbin is 2*lim+3*labc
c
      call wbin1 (ityp,nlat,m,wb,imid,i3,wwbin,wwbin(iw1),wwbin(iw2),
     1            wwbin(iw3),wwbin(iw4),i1,i2)
      return
      end
      subroutine wbin1 (ityp,nlat,m,wb,imid,i3,wb1,wb2,a,b,c,i1,i2)
      implicit double precision (a-h,o-z)
      dimension       wb(imid,nlat,3),wb1(imid,1),wb2(imid,1),
     1                a(1),b(1),c(1)
      ihold = i1
      i1 = i2
      i2 = i3
      i3 = ihold
      if(m-2)25,30,35
   25 i1 = 1
      i2 = 2
      i3 = 3
      do 45 np1=2,nlat
      do 45 i=1,imid
      wb(i,np1,i3) = wb1(i,np1)
   45 continue
      return
   30 do 50 np1=3,nlat
      do 50 i=1,imid
      wb(i,np1,i3) = wb2(i,np1)
   50 continue
      return
   35 ns = ((m-2)*(nlat+nlat-m-1))/2+1
      if(ityp .eq. 1) go to 36
      do 85 i=1,imid
      wb(i,m+1,i3) = a(ns)*wb(i,m-1,i1)-c(ns)*wb(i,m+1,i1)
   85 continue
   36 if(m .eq. nlat-1) return
      if(ityp .eq. 2) go to 71
      ns = ns+1
      do 70 i=1,imid
      wb(i,m+2,i3) = a(ns)*wb(i,m,i1)-c(ns)*wb(i,m+2,i1)
   70 continue
   71 nstrt = m+3
      if(ityp .eq. 1) nstrt = m+4
      if(nstrt .gt. nlat) go to 80
      nstp = 2
      if(ityp .eq. 0) nstp = 1
      do 75 np1=nstrt,nlat,nstp
      ns = ns+nstp
      do 75 i=1,imid
      wb(i,np1,i3) = a(ns)*wb(i,np1-2,i1)+b(ns)*wb(i,np1-2,i3)
     1                              -c(ns)*wb(i,np1,i1)
   75 continue
   80 return
      end
      subroutine dzvk(nlat,m,n,czv,work)
      implicit double precision (a-h,o-z)
c
c     subroutine dzvk computes the coefficients in the trigonometric
c     expansion of the quadrature function zvbar(n,m,theta)
c
c     input parameters
c
c     nlat      the number of colatitudes including the poles.
c
c     n      the degree (subscript) of wbarv(n,m,theta)
c
c     m      the order (superscript) of wbarv(n,m,theta)
c
c     work   a work array with at least nlat/2+1 locations
c
c     output parameter
c
c     czv     the fourier coefficients of zvbar(n,m,theta).
c
      dimension czv(1),work(1)
      double precision czv,sc1,sum,work,t1,t2
      if(n .le. 0) return
      lc = (nlat+1)/2
      sc1 = 2.d0/dfloat(nlat-1)
      call dvbk(m,n,work,czv)
      nmod = mod(n,2)
      mmod = mod(m,2)
      if(nmod .ne. 0) go to 1
      if(mmod .ne. 0) go to 2
c
c     n even, m even
c
      kdo = n/2
      do 9 id=1,lc
      i = id+id-2
      sum = 0.d0
      do 10 k=1,kdo
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
      sum = sum+work(k)*(t1-t2)/(t1*t2)
   10 continue
      czv(id) = sc1*sum
    9 continue
      return
c
c     n even, m odd
c
    2 kdo = n/2
      do 5 id=1,lc
      i = id+id-2
      sum = 0.d0
      do 6 k=1,kdo
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
      sum = sum+work(k)*(t1+t2)/(t1*t2)
    6 continue
      czv(id) = sc1*sum
    5 continue
      return
    1 if(mmod .ne. 0) go to 3
c
c     n odd, m even
c
      kdo = (n+1)/2
      do 19 id=1,lc
      i = id+id-3
      sum = 0.d0
      do 20 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
      sum = sum+work(k)*(t1-t2)/(t1*t2)
   20 continue
      czv(id) = sc1*sum
   19 continue
      return
c
c     n odd, m odd
c
    3 kdo = (n+1)/2
      do 15 id=1,lc
      i = id+id-1
      sum = 0.d0
      do 16 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
      sum = sum+work(k)*(t1+t2)/(t1*t2)
   16 continue
      czv(id) = sc1*sum
   15 continue
      return
      end
      subroutine dzvt(nlat,m,n,th,czv,zvh)
      implicit double precision (a-h,o-z)
c
c     subroutine dzvt tabulates the function zvbar(n,m,theta)
c     at theta = th in double precision
c
c     input parameters
c
c     nlat      the number of colatitudes including the poles.
c
c     n      the degree (subscript) of zvbar(n,m,theta)
c
c     m      the order (superscript) of zvbar(n,m,theta)
c
c     czv     the fourier coefficients of zvbar(n,m,theta)
c             as computed by subroutine zwk.
c
c     output parameter
c
c     zvh     zvbar(m,n,theta) evaluated at theta = th
c
      dimension czv(1)
      double precision th,czv,zvh,cth,sth,cdt,sdt,chh
      zvh = 0.d0
      if(n .le. 0) return
      lc = (nlat+1)/2
      lq = lc-1
      ls = lc-2
      cth = dcos(th)
      sth = dsin(th)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      lmod = mod(nlat,2)
      mmod = mod(m,2)
      nmod = mod(n,2)
      if(lmod .eq. 0) go to 50
      if(nmod .ne. 0) go to 1
      cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 2
c
c     nlat odd  n even  m even
c
      do 10 k=1,ls
      zvh = zvh+czv(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     nlat odd  n even  m odd
c
    2 zvh = .5d0*czv(1)
      do 20 k=2,lq
      zvh = zvh+czv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      zvh = zvh+.5d0*czv(lc)*dcos((nlat-1)*th)
      return
    1 if(mmod .ne. 0) go to 3
c
c     nlat odd  n odd  m even
c
      do 30 k=1,lq
      zvh = zvh+czv(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   30 continue
      return
c
c     nlat odd  n odd  m odd
c
    3 do 40 k=1,lq
      zvh = zvh+czv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   40 continue
      return
   50 if(nmod .ne. 0) go to 51
      cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 52
c
c     nlat even  n even  m even
c
      do 55 k=1,lq
      zvh = zvh+czv(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   55 continue
      return
c
c     nlat even  n even  m odd
c
   52 zvh = .5d0*czv(1)
      do 57 k=2,lc
      zvh = zvh+czv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   57 continue
      return
   51 if(mmod .ne. 0) go to 53
c
c     nlat even  n odd  m even
c
      do 58 k=1,lq
      zvh = zvh+czv(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   58 continue
      return
c
c     nlat even  n odd  m odd
c
   53 zvh = .5d0*czv(lc)*dcos((nlat-1)*th)
      do 60 k=1,lq
      zvh = zvh+czv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   60 continue
      return
      end
      subroutine dzwk(nlat,m,n,czw,work)
      implicit double precision (a-h,o-z)
c
c     subroutine dzwk computes the coefficients in the trigonometric
c     expansion of the quadrature function zwbar(n,m,theta)
c
c     input parameters
c
c     nlat      the number of colatitudes including the poles.
c
c     n      the degree (subscript) of zwbar(n,m,theta)
c
c     m      the order (superscript) of zwbar(n,m,theta)
c
c     work   a work array with at least nlat/2+1 locations
c
c     output parameter
c
c     czw     the fourier coefficients of zwbar(n,m,theta).
c
      dimension czw(1),work(1)
      double precision czw,work,sc1,sum,t1,t2
      if(n .le. 0) return
      lc = (nlat+1)/2
      sc1 = 2.d0/dfloat(nlat-1)
      call dwbk(m,n,work,czw)
      nmod = mod(n,2)
      mmod = mod(m,2)
      if(nmod .ne. 0) go to 1
      if(mmod .ne. 0) go to 2
c
c     n even, m even
c
      kdo = n/2
      do 19 id=1,lc
      i = id+id-3
      sum = 0.d0
      do 20 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
      sum = sum+work(k)*(t1-t2)/(t1*t2)
   20 continue
      czw(id) = sc1*sum
   19 continue
      return
c
c     n even, m odd
c
    2 kdo = n/2
      do 15 id=1,lc
      i = id+id-1
      sum = 0.d0
      do 16 k=1,kdo
      t1 = 1.d0-(k+k-1+i)**2
      t2 = 1.d0-(k+k-1-i)**2
      sum = sum+work(k)*(t1+t2)/(t1*t2)
   16 continue
      czw(id) = sc1*sum
   15 continue
      return
    1 if(mmod .ne. 0) go to 3
c
c     n odd, m even
c
      kdo = (n-1)/2
      do 9 id=1,lc
      i = id+id-2
      sum = 0.d0
      do 10 k=1,kdo
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
      sum = sum+work(k)*(t1-t2)/(t1*t2)
   10 continue
      czw(id) = sc1*sum
    9 continue
      return
c
c     n odd, m odd
c
    3 kdo = (n+1)/2
      do 5 id=1,lc
      i = id+id-2
      sum = work(1)/(1.d0-i*i)
      if(kdo .lt. 2) go to 29
      do 6 kp1=2,kdo
      k = kp1-1
      t1 = 1.d0-(k+k+i)**2
      t2 = 1.d0-(k+k-i)**2
      sum = sum+work(kp1)*(t1+t2)/(t1*t2)
    6 continue
   29 czw(id) = sc1*sum
    5 continue
      return
      end
      subroutine dzwt(nlat,m,n,th,czw,zwh)
      implicit double precision (a-h,o-z)
c
c     subroutine dzwt tabulates the function zwbar(n,m,theta)
c     at theta = th in double precision
c
c     input parameters
c
c     nlat      the number of colatitudes including the poles.
c            nlat must be an odd integer
c
c     n      the degree (subscript) of zwbar(n,m,theta)
c
c     m      the order (superscript) of zwbar(n,m,theta)
c
c     czw     the fourier coefficients of zwbar(n,m,theta)
c             as computed by subroutine zwk.
c
c     output parameter
c
c     zwh     zwbar(m,n,theta) evaluated at theta = th
c
      dimension czw(1)
      double precision czw,zwh,th,cth,sth,cdt,sdt,chh
      zwh = 0.d0
      if(n .le. 0) return
      lc = (nlat+1)/2
      lq = lc-1
      ls = lc-2
      cth = dcos(th)
      sth = dsin(th)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      lmod = mod(nlat,2)
      mmod = mod(m,2)
      nmod = mod(n,2)
      if(lmod .eq. 0) go to 50
      if(nmod .ne. 0) go to 1
      if(mmod .ne. 0) go to 2
c
c     nlat odd  n even  m even
c
      do 30 k=1,lq
      zwh = zwh+czw(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   30 continue
      return
c
c     nlat odd  n even  m odd
c
    2 do 40 k=1,lq
      zwh = zwh+czw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   40 continue
      return
    1 cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 3
c
c     nlat odd  n odd  m even
c
      do 10 k=1,ls
      zwh = zwh+czw(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     nlat odd  n odd  m odd
c
    3 zwh = .5d0*czw(1)
      do 20 k=2,lq
      zwh = zwh+czw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      zwh = zwh+.5d0*czw(lc)*dcos((nlat-1)*th)
      return
   50 if(nmod .ne. 0) go to 51
      if(mmod .ne. 0) go to 52
c
c     nlat even  n even  m even
c
      do 55 k=1,lq
      zwh = zwh+czw(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   55 continue
      return
c
c     nlat even  n even  m odd
c
   52 zwh = .5d0*czw(lc)*dcos((nlat-1)*th)
      do 60 k=1,lq
      zwh = zwh+czw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   60 continue
      return
   51 cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 53
c
c     nlat even  n odd  m even
c
      do 65 k=1,lq
      zwh = zwh+czw(k+1)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   65 continue
      return
c
c     nlat even  n odd  m odd
c
   53 zwh = .5d0*czw(1)
      do 70 k=2,lc
      zwh = zwh+czw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   70 continue
      return
      end
      subroutine dvbk(m,n,cv,work)
      implicit double precision (a-h,o-z)
      double precision cv(1),work(1),fn,fk,cf
      cv(1) = 0.d0
      if(n .le. 0) return
      fn = n
      srnp1 = dsqrt(fn*(fn+1.d0))
      cf = 2.d0*m/srnp1
      modn = mod(n,2)
      modm = mod(m,2)
      call dnlfk(m,n,work)
      if(modn .ne. 0) go to 70
      ncv = n/2
      if(ncv .eq. 0) return
      fk = 0.d0
      if(modm .ne. 0) go to 60
c
c     n even m even
c
      do 55 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*work(l+1)/srnp1
   55 continue
      return
c
c     n even m odd
c
   60 do 65 l=1,ncv
      fk = fk+2.d0
      cv(l) = fk*work(l)/srnp1
   65 continue
      return
   70 ncv = (n+1)/2
      fk = -1.d0
      if(modm .ne. 0) go to 80
c
c     n odd m even
c
      do 75 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*work(l)/srnp1
   75 continue
      return
c
c     n odd m odd
c
   80 do 85 l=1,ncv
      fk = fk+2.d0
      cv(l) = fk*work(l)/srnp1
   85 continue
      return
      end
      subroutine dwbk(m,n,cw,work)
      implicit double precision (a-h,o-z)
      double precision cw(1),work(1),fn,cf,srnp1
      cw(1) = 0.d0
      if(n.le.0 .or. m.le.0) return
      fn = n
      srnp1 = dsqrt(fn*(fn+1.d0))
      cf = 2.d0*m/srnp1
      modn = mod(n,2)
      modm = mod(m,2)
      call dnlfk(m,n,work)
      if(m .eq. 0) go to 50
      if(modn .ne. 0) go to 30
      l = n/2
      if(l .eq. 0) go to 50
      if(modm .ne. 0) go to 20
c
c     n even m even
c
      cw(l) = -cf*work(l+1)
   10 l = l-1
      if(l .le. 0) go to 50
      cw(l) = cw(l+1)-cf*work(l+1)
      go to 10
c
c     n even m odd
c
   20 cw(l) = cf*work(l)
   25 l = l-1
      if(l .le. 0) go to 50
      cw(l) = cw(l+1)+cf*work(l)
      go to 25
   30 if(modm .ne. 0) go to 40
      l = (n-1)/2
      if(l .eq. 0) go to 50
c
c     n odd m even
c
      cw(l) = -cf*work(l+1)
   35 l = l-1
      if(l .le. 0) go to 50
      cw(l) = cw(l+1)-cf*work(l+1)
      go to 35
c
c     n odd m odd
c
   40 l = (n+1)/2
      cw(l) = cf*work(l)
   45 l = l-1
      if(l .le. 0) go to 50
      cw(l) = cw(l+1)+cf*work(l)
      go to 45
   50 return
      end
      subroutine dvbt(m,n,theta,cv,vh)
      implicit double precision (a-h,o-z)
      dimension cv(1)
      double precision cv,vh,theta,cth,sth,cdt,sdt,chh
      vh = 0.d0
      if(n.eq.0) return
      cth = dcos(theta)
      sth = dsin(theta)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      mmod = mod(m,2)
      nmod = mod(n,2)
      if(nmod .ne. 0) go to 1
      cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 2
c
c     n even  m even
c
      ncv = n/2
      do 10 k=1,ncv
      vh = vh+cv(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     n even  m odd
c
    2 ncv = n/2
      do 15 k=1,ncv
      vh = vh+cv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   15 continue
      return
    1 if(mmod .ne. 0) go to 3
c
c     n odd m even
c
      ncv = (n+1)/2
      do 20 k=1,ncv
      vh = vh+cv(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      return
c
c case m odd and n odd
c
    3 ncv = (n+1)/2
      do 25 k=1,ncv
      vh = vh+cv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   25 continue
      return
      end
      subroutine dwbt(m,n,theta,cw,wh)
      implicit double precision (a-h,o-z)
      dimension cw(1)
      double precision theta,cw,wh,cth,sth,cdt,sdt,chh
      wh = 0.d0
      if(n.le.0 .or. m.le.0) return
      cth = dcos(theta)
      sth = dsin(theta)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      mmod=mod(m,2)
      nmod=mod(n,2)
      if(nmod .ne. 0) go to 1
      if(mmod .ne. 0) go to 2
c
c     n even  m even
c
      ncw = n/2
      do 10 k=1,ncw
      wh = wh+cw(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     n even  m odd
c
    2 ncw = n/2
      do 8 k=1,ncw
      wh = wh+cw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
    8 continue
      return
    1 cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 3
c
c     n odd m even
c
      ncw = (n-1)/2
      do 20 k=1,ncw
      wh = wh+cw(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      return
c
c case m odd and n odd
c
    3 ncw = (n+1)/2
      wh = .5d0*cw(1)
      if(ncw.lt.2) return
      do 25 k=2,ncw
      wh = wh+cw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   25 continue
      return
      end
      subroutine rabcv(nlat,nlon,abc)
      implicit double precision (a-h,o-z)
c
c     subroutine rabcp computes the coefficients in the recurrence
c     relation for the functions vbar(m,n,theta). array abc
c     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
c
      dimension abc(1)
      mmax = min0(nlat,(nlon+1)/2)
      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      iw1 = labc+1
      iw2 = iw1+labc
      call rabcv1(nlat,nlon,abc,abc(iw1),abc(iw2))
      return
      end
      subroutine rabcv1(nlat,nlon,a,b,c)
      implicit double precision (a-h,o-z)
c
c     coefficients a, b, and c for computing vbar(m,n,theta) are
c     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
c
      dimension a(1),b(1),c(1)
      mmax = min0(nlat,(nlon+1)/2)
      if(mmax .lt. 3) return
      do 215 mp1=3,mmax
      m = mp1-1
      ns = ((m-2)*(nlat+nlat-m-1))/2+1
      fm = dfloat(m)
      tm = fm+fm
      temp = tm*(tm-1.d0)
      tpn = (fm-2.d0)*(fm-1.d0)/(fm*(fm+1.d0))
      a(ns) = dsqrt(tpn*(tm+1.d0)*(tm-2.d0)/temp)
      c(ns) = dsqrt(2.d0/temp)
      if(m .eq. nlat-1) go to 215
      ns = ns+1
      temp = tm*(tm+1.d0)
      tpn = (fm-1.d0)*fm/((fm+1.d0)*(fm+2.d0))
      a(ns) = dsqrt(tpn*(tm+3.d0)*(tm-2.d0)/temp)
      c(ns) = dsqrt(6.d0/temp)
      mp3 = m+3
      if(mp3 .gt. nlat) go to 215
      do 210 np1=mp3,nlat
      n = np1-1
      ns = ns+1
      fn = dfloat(n)
      tn = fn+fn
      cn = (tn+1.d0)/(tn-3.d0)
      tpn = (fn-2.d0)*(fn-1.d0)/(fn*(fn+1.d0))
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.d0)
      a(ns) = dsqrt(tpn*cn*(fnpm-3.d0)*(fnpm-2.d0)/temp)
      b(ns) = dsqrt(tpn*cn*fnmm*(fnmm-1.d0)/temp)
      c(ns) = dsqrt((fnmm+1.d0)*(fnmm+2.d0)/temp)
  210 continue
  215 continue
      return
      end
      subroutine rabcw(nlat,nlon,abc)
      implicit double precision (a-h,o-z)
c
c     subroutine rabcw computes the coefficients in the recurrence
c     relation for the functions wbar(m,n,theta). array abc
c     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
c
      dimension abc(1)
      mmax = min0(nlat,(nlon+1)/2)
      labc = (max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      iw1 = labc+1
      iw2 = iw1+labc
      call rabcw1(nlat,nlon,abc,abc(iw1),abc(iw2))
      return
      end
      subroutine rabcw1(nlat,nlon,a,b,c)
      implicit double precision (a-h,o-z)
c
c     coefficients a, b, and c for computing wbar(m,n,theta) are
c     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
c
      dimension a(1),b(1),c(1)
      mmax = min0(nlat,(nlon+1)/2)
      if(mmax .lt. 4) return
      do 215 mp1=4,mmax
      m = mp1-1
      ns = ((m-2)*(nlat+nlat-m-1))/2+1
      fm = dfloat(m)
      tm = fm+fm
      temp = tm*(tm-1.d0)
      tpn = (fm-2.d0)*(fm-1.d0)/(fm*(fm+1.d0))
      tph = fm/(fm-2.d0)
      a(ns) = tph*dsqrt(tpn*(tm+1.d0)*(tm-2.d0)/temp)
      c(ns) = tph*dsqrt(2.d0/temp)
      if(m .eq. nlat-1) go to 215
      ns = ns+1
      temp = tm*(tm+1.d0)
      tpn = (fm-1.d0)*fm/((fm+1.d0)*(fm+2.d0))
      tph = fm/(fm-2.d0)
      a(ns) = tph*dsqrt(tpn*(tm+3.d0)*(tm-2.d0)/temp)
      c(ns) = tph*dsqrt(6.d0/temp)
      mp3 = m+3
      if(mp3 .gt. nlat) go to 215
      do 210 np1=mp3,nlat
      n = np1-1
      ns = ns+1
      fn = dfloat(n)
      tn = fn+fn
      cn = (tn+1.d0)/(tn-3.d0)
      fnpm = fn+fm
      fnmm = fn-fm
      temp = fnpm*(fnpm-1.d0)
      tpn = (fn-2.d0)*(fn-1.d0)/(fn*(fn+1.d0))
      tph = fm/(fm-2.d0)
      a(ns) = tph*dsqrt(tpn*cn*(fnpm-3.d0)*(fnpm-2.d0)/temp)
      b(ns) = dsqrt(tpn*cn*fnmm*(fnmm-1.d0)/temp)
      c(ns) = tph*dsqrt((fnmm+1.d0)*(fnmm+2.d0)/temp)
  210 continue
  215 continue
      return
      end
      subroutine vtinit (nlat,nlon,wvbin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wvbin(*)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of dwork is nlat+2
c
      call vtini1 (nlat,nlon,imid,wvbin,wvbin(iw1),dwork,
     1                                       dwork(nlat/2+2))
      return
      end
      subroutine vtini1 (nlat,nlon,imid,vb,abc,cvb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cvb and work must each have nlat/2+1 locations
c
      dimension vb(imid,nlat,2),abc(1),cvb(1)
      double precision pi,dt,cvb,th,vbh,work(*)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(2,nlat,(nlon+1)/2)
      do 160 mp1=1,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dvtk(m,n,cvb,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dvtt(m,n,th,cvb,vbh)
      vb(i,np1,mp1) = vbh
  165 continue
  160 continue
      call rabcv(nlat,nlon,abc)
      return
      end
      subroutine wtinit (nlat,nlon,wwbin,dwork)
      implicit double precision (a-h,o-z)
      dimension       wwbin(1)
      double precision dwork(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of dwork is nlat+2
c
      call wtini1 (nlat,nlon,imid,wwbin,wwbin(iw1),dwork,
     1                                       dwork(nlat/2+2))
      return
      end
      subroutine wtini1 (nlat,nlon,imid,wb,abc,cwb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cwb and work must each have nlat/2+1 locations
c
      dimension wb(imid,nlat,2),abc(1)
      double precision pi,dt,cwb(*),wbh,th,work(*)
      pi = 4.d0*datan(1.d0)
      dt = pi/(nlat-1)
      mdo = min0(3,nlat,(nlon+1)/2)
      if(mdo .lt. 2) return
      do 160 mp1=2,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dwtk(m,n,cwb,work)
      do 165 i=1,imid
      th = (i-1)*dt
      call dwtt(m,n,th,cwb,wbh)
      wb(i,np1,m) = wbh
  165 continue
  160 continue
      call rabcw(nlat,nlon,abc)
      return
      end
      subroutine vtgint (nlat,nlon,theta,wvbin,work)
      implicit double precision (a-h,o-z)
      dimension       wvbin(*)
      double precision theta(*), work(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     theta is a double precision array with (nlat+1)/2 locations
c     nlat is the maximum value of n+1
c     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of work is nlat+2
c
      call vtgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1),
     +                        work,work(nlat/2+2))
      return
      end
      subroutine vtgit1 (nlat,nlon,imid,theta,vb,abc,cvb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cvb and work must each have nlat/2+1   locations
c
      dimension vb(imid,nlat,2),abc(*)
      double precision theta(*),cvb(*),work(*),vbh
      mdo = min0(2,nlat,(nlon+1)/2)
      do 160 mp1=1,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dvtk(m,n,cvb,work)
      do 165 i=1,imid
      call dvtt(m,n,theta(i),cvb,vbh)
      vb(i,np1,mp1) = vbh
  165 continue
  160 continue
      call rabcv(nlat,nlon,abc)
      return
      end
      subroutine wtgint (nlat,nlon,theta,wwbin,work)
      implicit double precision (a-h,o-z)
      dimension       wwbin(*)
      double precision theta(*), work(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     theta is a double precision array with (nlat+1)/2 locations
c     nlat is the maximum value of n+1
c     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of work is nlat+2
c
      call wtgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1),
     1                        work,work(nlat/2+2))
      return
      end
      subroutine wtgit1 (nlat,nlon,imid,theta,wb,abc,cwb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*((nlat-3)*nlat+2)/2 locations
c     cwb and work must each have nlat/2+1 locations
c
      dimension wb(imid,nlat,2),abc(1)
      double precision theta(*), cwb(*), work(*), wbh
      mdo = min0(3,nlat,(nlon+1)/2)
      if(mdo .lt. 2) return
      do 160 mp1=2,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dwtk(m,n,cwb,work)
      do 165 i=1,imid
      call dwtt(m,n,theta(i),cwb,wbh)
      wb(i,np1,m) = wbh
  165 continue
  160 continue
      call rabcw(nlat,nlon,abc)
      return
      end
      subroutine dvtk(m,n,cv,work)
      implicit double precision (a-h,o-z)
      double precision cv(*),work(*),fn,fk,cf,srnp1
      cv(1) = 0.d0
      if(n .le. 0) return
      fn = n
      srnp1 = dsqrt(fn*(fn+1.d0))
      cf = 2.d0*m/srnp1
      modn = mod(n,2)
      modm = mod(m,2)
      call dnlfk(m,n,work)
      if(modn .ne. 0) go to 70
      ncv = n/2
      if(ncv .eq. 0) return
      fk = 0.d0
      if(modm .ne. 0) go to 60
c
c     n even m even
c
      do 55 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*fk*work(l+1)/srnp1
   55 continue
      return
c
c     n even m odd
c
   60 do 65 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*fk*work(l)/srnp1
   65 continue
      return
   70 ncv = (n+1)/2
      fk = -1.d0
      if(modm .ne. 0) go to 80
c
c     n odd m even
c
      do 75 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*fk*work(l)/srnp1
   75 continue
      return
c
c     n odd m odd
c
   80 do 85 l=1,ncv
      fk = fk+2.d0
      cv(l) = -fk*fk*work(l)/srnp1
   85 continue
      return
      end
      subroutine dwtk(m,n,cw,work)
      implicit double precision (a-h,o-z)
      double precision cw(*),work(*),fn,cf,srnp1
      cw(1) = 0.d0
      if(n.le.0 .or. m.le.0) return
      fn = n
      srnp1 = dsqrt(fn*(fn+1.d0))
      cf = 2.d0*m/srnp1
      modn = mod(n,2)
      modm = mod(m,2)
      call dnlfk(m,n,work)
      if(m .eq. 0) go to 50
      if(modn .ne. 0) go to 30
      l = n/2
      if(l .eq. 0) go to 50
      if(modm .ne. 0) go to 20
c
c     n even m even
c
      cw(l) = -cf*work(l+1)
   10 l = l-1
      if(l .le. 0) go to 50
      cw(l) = cw(l+1)-cf*work(l+1)
      cw(l+1) = (l+l+1)*cw(l+1)
      go to 10
c
c     n even m odd
c
   20 cw(l) = cf*work(l)
   25 l = l-1
      if(l) 50,27,26
   26 cw(l) = cw(l+1)+cf*work(l)
   27 cw(l+1) = -(l+l+1)*cw(l+1)
      go to 25
   30 if(modm .ne. 0) go to 40
      l = (n-1)/2
      if(l .eq. 0) go to 50
c
c     n odd m even
c
      cw(l) = -cf*work(l+1)
   35 l = l-1
      if(l) 50,37,36
   36 cw(l) = cw(l+1)-cf*work(l+1)
   37 cw(l+1) = (l+l+2)*cw(l+1)
      go to 35
c
c     n odd m odd
c
   40 l = (n+1)/2
      cw(l) = cf*work(l)
   45 l = l-1
      if(l) 50,47,46
   46 cw(l) = cw(l+1)+cf*work(l)
   47 cw(l+1) = -(l+l)*cw(l+1)
      go to 45
   50 return
      end
      subroutine dvtt(m,n,theta,cv,vh)
      implicit double precision (a-h,o-z)
      dimension cv(1)
      double precision cv,vh,theta,cth,sth,cdt,sdt,chh
      vh = 0.d0
      if(n.eq.0) return
      cth = dcos(theta)
      sth = dsin(theta)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      mmod = mod(m,2)
      nmod = mod(n,2)
      if(nmod .ne. 0) go to 1
      cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 2
c
c     n even  m even
c
      ncv = n/2
      do 10 k=1,ncv
      vh = vh+cv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     n even  m odd
c
    2 ncv = n/2
      do 15 k=1,ncv
      vh = vh+cv(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   15 continue
      return
    1 if(mmod .ne. 0) go to 3
c
c     n odd m even
c
      ncv = (n+1)/2
      do 20 k=1,ncv
      vh = vh+cv(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      return
c
c case m odd and n odd
c
    3 ncv = (n+1)/2
      do 25 k=1,ncv
      vh = vh+cv(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   25 continue
      return
      end
      subroutine dwtt(m,n,theta,cw,wh)
      implicit double precision (a-h,o-z)
      dimension cw(1)
      double precision theta,cw,wh,cth,sth,cdt,sdt,chh
      wh = 0.d0
      if(n.le.0 .or. m.le.0) return
      cth = dcos(theta)
      sth = dsin(theta)
      cdt = cth*cth-sth*sth
      sdt = 2.d0*sth*cth
      mmod=mod(m,2)
      nmod=mod(n,2)
      if(nmod .ne. 0) go to 1
      if(mmod .ne. 0) go to 2
c
c     n even  m even
c
      ncw = n/2
      do 10 k=1,ncw
      wh = wh+cw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   10 continue
      return
c
c     n even  m odd
c
    2 ncw = n/2
      do 8 k=1,ncw
      wh = wh+cw(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
    8 continue
      return
    1 cth = cdt
      sth = sdt
      if(mmod .ne. 0) go to 3
c
c     n odd m even
c
      ncw = (n-1)/2
      do 20 k=1,ncw
      wh = wh+cw(k)*cth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   20 continue
      return
c
c case m odd and n odd
c
    3 ncw = (n+1)/2
      wh = 0.d0
      if(ncw.lt.2) return
      do 25 k=2,ncw
      wh = wh+cw(k)*sth
      chh = cdt*cth-sdt*sth
      sth = sdt*cth+cdt*sth
      cth = chh
   25 continue
      return
      end
      subroutine vbgint (nlat,nlon,theta,wvbin,work)
      implicit double precision (a-h,o-z)
      dimension       wvbin(1)
      double precision theta(*),work(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     theta is a double precision array with (nlat+1)/2 locations
c     nlat is the maximum value of n+1
c     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of work is nlat+2
c
      call vbgit1 (nlat,nlon,imid,theta,wvbin,wvbin(iw1),
     +                        work,work(nlat/2+2))
      return
      end
      subroutine vbgit1 (nlat,nlon,imid,theta,vb,abc,cvb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
c     locations where mmax = min0(nlat,(nlon+1)/2)
c     cvb and work must each have nlat/2+1 locations
c
      dimension vb(imid,nlat,2),abc(1)
      double precision cvb(1),theta(1),vbh,work(1)
      mdo = min0(2,nlat,(nlon+1)/2)
      do 160 mp1=1,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dvbk(m,n,cvb,work)
      do 165 i=1,imid
      call dvbt(m,n,theta(i),cvb,vbh)
      vb(i,np1,mp1) = vbh
  165 continue
  160 continue
      call rabcv(nlat,nlon,abc)
      return
      end
      subroutine wbgint (nlat,nlon,theta,wwbin,work)
      implicit double precision (a-h,o-z)
      dimension       wwbin(1)
      double precision work(*),theta(*)
      imid = (nlat+1)/2
      iw1 = 2*nlat*imid+1
c
c     theta is a double precision array with (nlat+1)/2 locations
c     nlat is the maximum value of n+1
c     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
c     the length of work is nlat+2
c
      call wbgit1 (nlat,nlon,imid,theta,wwbin,wwbin(iw1),
     +                        work,work(nlat/2+2))
      return
      end
      subroutine wbgit1 (nlat,nlon,imid,theta,wb,abc,cwb,work)
      implicit double precision (a-h,o-z)
c
c     abc must have 3*((nlat-3)*nlat+2)/2 locations
c     cwb and work must each have nlat/2+1 locations
c
      dimension wb(imid,nlat,2),abc(1)
      double precision cwb(1),theta(1),wbh,work(1)
      mdo = min0(3,nlat,(nlon+1)/2)
      if(mdo .lt. 2) return
      do 160 mp1=2,mdo
      m = mp1-1
      do 160 np1=mp1,nlat
      n = np1-1
      call dwbk(m,n,cwb,work)
      do 165 i=1,imid
      call dwbt(m,n,theta(i),cwb,wbh)
      wb(i,np1,m) = wbh
  165 continue
  160 continue
      call rabcw(nlat,nlon,abc)
      return
      end


C$Procedure UDDC ( Derivative of function less than zero, df(x)/dx < 0 )

      SUBROUTINE UDDC ( UDFUNC, X, DX, ISDECR )

C$ Abstract
C
C    This routine calculates the derivative of UDFUNC with respect
C    to time for X, then determines if the derivative has
C    a negative value.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C    MATH
C    DERIVATIVE
C
C$ Declarations

      IMPLICIT NONE

      EXTERNAL              UDFUNC

      DOUBLE PRECISION      X
      DOUBLE PRECISION      DX
      LOGICAL               ISDECR

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     UDFUNC     I   The routine that computes the scalar value
C                    of interest.
C     X          I   Independent variable of UDFUNC.
C     DX         I   Interval from X for derivative calculation.
C     ISDECR     O   Boolean indicating if the derivative is negative.
C
C$ Detailed_Input
C
C     UDFUNC     the routine that returns the value of the scalar
C                quantity function of interest at X. The calling
C                sequence for UDFUNC is:
C
C                   CALL UDFUNC ( X, VALUE )
C
C                where:
C
C                   X       the double precision value of the
C                           independent variable of the function
C                           at which to determine the scalar value.
C
C                   VALUE   the double precision value returned by
C                           UDFUNC at X.
C
C                Functionally:
C
C                   VALUE = UDFUNC ( X )
C
C     X          a scalar double precision value at which to determine
C                the derivative of UDFUNC.
C
C                For many SPICE uses, X will represent ephemeris time,
C                expressed as seconds past J2000 TDB.
C
C     DX         a scalar double precision value representing half the
C                interval in units of X separating the evaluation
C                values of UDFUNC; the evaluations occur at (X + DX)
C                and (X - DX).
C
C                DX may be negative but must be non-zero.
C
C$ Detailed_Output
C
C     ISDECR      a scalar boolean indicating if the first derivative
C                 of UDFUNC with respect to the independent variable
C                 at X is less than zero.
C
C                 Functionally:
C
C                               d UDFUNC(x) |
C                    ISDECR =   --          |  <  0
C                               dx          |
C                                            X
C
C$ Parameters
C
C    None.
C
C$ Exceptions
C
C     1) A routine in the call tree of this routine signals
C        SPICE(DIVIDEBYZERO) if DX has a value of zero.
C
C$ Files
C
C     If the evaluation of UDFUNC requires SPICE kernel data, the
C     appropriate kernels must be loaded before calling this routine.
C
C        - SPK data: the calling application must load ephemeris data
C          for the targets, observer, and any intermediate objects in
C          a chain connecting the targets and observer for the time
C          used in the evaluation. If aberration corrections are
C          used, the states of target and observer relative to the
C          solar system barycenter must be calculable from the
C          available ephemeris data.
C
C        - If non-inertial reference frames are used, then PCK
C          files, frame kernels, C-kernels, and SCLK kernels may be
C          needed.
C
C     Such kernel data are normally loaded once per program run, NOT
C     every time this routine is called.
C
C$ Particulars
C
C    This routine only wraps a UDDF call, examining the sign of the
C    derivative value returned by UDDF.
C
C$ Examples
C
C    See GFUDS.
C
C$ Restrictions
C
C    None.
C
C$ Literature_References
C
C    See UDDF header
C
C$ Author_and_Institution
C
C    N.J. Bachman   (JPL)
C    E.D. Wright    (JPL)
C
C$ Version
C
C-   SPICELIB Version 1.0.0,  31-MAR-2010 (EDW)
C
C-&

C$ Index_Entries
C
C    first derivative of scalar function less than zero
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               FAILED

C
C     Local Variables
C
      DOUBLE PRECISION      DERIV

      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'UDDC' )

      ISDECR = .FALSE.

C
C     Numerically calculate the derivative of UDFUNC at X.
C
      CALL UDDF ( UDFUNC, X, DX, DERIV )

      IF (  FAILED() ) THEN
         CALL CHKOUT ( 'UDDC' )
         RETURN
      END IF

      ISDECR = DERIV .LT. 0.D0

      CALL CHKOUT ( 'UDDC' )
      RETURN

      END


	SUBROUTINE PS_LCLL  ( datain, tlcl, plcl, iret )
C************************************************************************
C* PS_LCLL								*
C*									*
C* This subroutine computes the lifted condensation level from the 	*
C* surface.								*
C*									*
C* PS_LCLL  ( DATAIN, TLCL, PLCL, IRET )				*
C*									*
C* Input parameters:							*
C*	DATAIN(*)	REAL		Input sounding data		*
C*									*
C* Output parameters:							*
C*	TLCL		REAL		LCL temperature			*
C*	PLCL		REAL		LCL pressure			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* K. Brill/NMC		 7/90						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL            datain (*)
C*
	REAL    	rdata (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	iret = 0
	tlcl = RMISSD
	plcl = RMISSD
C*
	CALL PC_CMDT ( 5, 6, 7, 0., 1, datain, rdata, ier )
C
C*	Find temperature and pressure at the LCL.
C
        prs = rdata (1)
	tmp = rdata (2)
	dwp = rdata (3)
	IF ( ( ier .ne. 0 ) .or. ERMISS ( prs ) .or. ERMISS ( tmp )
     +	     .or. ERMISS ( dwp ) )   RETURN
	tlcl = PR_TLCL ( tmp, dwp )
	plcl = PR_PLCL ( tmp, prs, tlcl )
C*
	RETURN
	END