!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
! ... file sphcom.f
!
!     this file must be loaded with all driver level files
!     in spherepack3.0.  it includes undocumented subroutines
!     called by some or all of the drivers
!
      SUBROUTINE DNLFK(M,N,Cp)
      IMPLICIT NONE
      INTEGER i , l , M , ma , N , nex , nmms2
!
      DOUBLE PRECISION Cp , fnum , fden , fnmh , a1 , b1 , c1 , cp2 ,   &
                     & fnnp1 , fnmsq , fk , t1 , t2 , pm1 , SC10 ,      &
                     & SC20 , SC40
      DIMENSION Cp(1)
      PARAMETER (SC10=1024.D0)
      PARAMETER (SC20=SC10*SC10)
      PARAMETER (SC40=SC20*SC20)
!
      Cp(1) = 0.
      ma = IABS(M)
      IF ( ma>N ) RETURN
      IF ( N<1 ) THEN
         Cp(1) = DSQRT(2.D0)
         RETURN
      ELSEIF ( N==1 ) THEN
         IF ( ma/=0 ) THEN
            Cp(1) = DSQRT(.75D0)
            IF ( M==-1 ) Cp(1) = -Cp(1)
            RETURN
         ELSE
            Cp(1) = DSQRT(1.5D0)
            RETURN
         ENDIF
      ELSE
         IF ( MOD(N+ma,2)/=0 ) THEN
            nmms2 = (N-ma-1)/2
            fnum = N + ma + 2
            fnmh = N - ma + 2
            pm1 = -1.D0
         ELSE
            nmms2 = (N-ma)/2
            fnum = N + ma + 1
            fnmh = N - ma + 1
            pm1 = 1.D0
         ENDIF
!      t1 = 1.
!      t1 = 2.d0**(n-1)
!      t1 = 1.d0/t1
         t1 = 1.D0/SC20
         nex = 20
         fden = 2.D0
         IF ( nmms2>=1 ) THEN
            DO i = 1 , nmms2
               t1 = fnum*t1/fden
               IF ( t1>SC20 ) THEN
                  t1 = t1/SC40
                  nex = nex + 40
               ENDIF
               fnum = fnum + 2.
               fden = fden + 2.
            ENDDO
         ENDIF
         t1 = t1/2.D0**(N-1-nex)
         IF ( MOD(ma/2,2)/=0 ) t1 = -t1
         t2 = 1.
         IF ( ma/=0 ) THEN
            DO i = 1 , ma
               t2 = fnmh*t2/(fnmh+pm1)
               fnmh = fnmh + 2.
            ENDDO
         ENDIF
         cp2 = t1*DSQRT((N+.5D0)*t2)
         fnnp1 = N*(N+1)
         fnmsq = fnnp1 - 2.D0*ma*ma
         l = (N+1)/2
         IF ( MOD(N,2)==0 .AND. MOD(ma,2)==0 ) l = l + 1
         Cp(l) = cp2
         IF ( M<0 ) THEN
            IF ( MOD(ma,2)/=0 ) Cp(l) = -Cp(l)
         ENDIF
         IF ( l<=1 ) RETURN
         fk = N
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = 2.*(fk*fk-fnmsq)
         Cp(l-1) = b1*Cp(l)/a1
 50      l = l - 1
         IF ( l<=1 ) RETURN
         fk = fk - 2.
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = -2.*(fk*fk-fnmsq)
         c1 = (fk+1.)*(fk+2.) - fnnp1
         Cp(l-1) = -(b1*Cp(l)+c1*Cp(l+1))/a1
         GOTO 50
      ENDIF
      END SUBROUTINE DNLFK


      SUBROUTINE DNLFT(M,N,Theta,Cp,Pb)
      IMPLICIT NONE
      INTEGER k , kdo , M , mmod , N , nmod
      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<=0 ) THEN
         IF ( mmod<=0 ) THEN
!
!     n even, m even
!
            kdo = N/2
            Pb = .5*Cp(1)
            IF ( N==0 ) RETURN
            cth = cdt
            sth = sdt
            DO k = 1 , kdo
!     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
            ENDDO
            RETURN
         ELSE
!
!     n even, m odd
!
            kdo = N/2
            Pb = 0.
            cth = cdt
            sth = sdt
            DO k = 1 , kdo
!     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
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod<=0 ) THEN
!
!     n odd, m even
!
         kdo = (N+1)/2
         Pb = 0.
         cth = DCOS(Theta)
         sth = DSIN(Theta)
         DO k = 1 , kdo
!     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
         ENDDO
         RETURN
      ELSE
!
!     n odd, m odd
!
         kdo = (N+1)/2
         Pb = 0.
         cth = DCOS(Theta)
         sth = DSIN(Theta)
         DO k = 1 , kdo
!     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
         ENDDO
      ENDIF
      END SUBROUTINE DNLFT


      SUBROUTINE LEGIN(Mode,L,Nlat,M,W,Pmn,Km)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , Km , L , late , M , Mode , Nlat
      REAL Pmn , W
!     this subroutine computes legendre polynomials for n=m,...,l-1
!     and  i=1,...,late (late=((nlat+mod(nlat,2))/2)gaussian grid
!     in pmn(n+1,i,km) using swarztrauber's recursion formula.
!     the vector w contains quantities precomputed in shigc.
!     legin must be called in the order m=0,1,...,l-1
!     (e.g., if m=10 is sought it must be preceded by calls with
!     m=0,1,2,...,9 in that order)
      DIMENSION W(1) , Pmn(1)
!     set size of pole to equator gaussian grid
      late = (Nlat+MOD(Nlat,2))/2
!     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),W(i5),Pmn, &
                & Km)
      END SUBROUTINE LEGIN


      SUBROUTINE LEGIN1(Mode,L,Nlat,Late,M,P0n,P1n,Abel,Bbel,Cbel,Pmn,  &
                      & Km)
      IMPLICIT NONE
      REAL Abel , Bbel , Cbel , P0n , P1n , Pmn
      INTEGER i , imn , IMNDX , INDX , Km , km0 , km1 , km2 , kmt , L , &
            & Late , M , Mode , ms , n , ninc , Nlat , np1
      DIMENSION P0n(Nlat,Late) , P1n(Nlat,Late)
      DIMENSION Abel(1) , Bbel(1) , Cbel(1) , Pmn(Nlat,Late,3)
      DATA km0 , km1 , km2/1 , 2 , 3/
      SAVE km0 , km1 , km2
!     define index function used in storing triangular
!     arrays for recursion coefficients (functions of (m,n))
!     for 2.le.m.le.n-1 and 2.le.n.le.l-1
      INDX(M,n) = (n-1)*(n-2)/2 + M - 1
!     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
 
!     set do loop indices for full or half sphere
      ms = M + 1
      ninc = 1
      IF ( Mode==1 ) THEN
!     only compute pmn for n-m odd
         ms = M + 2
         ninc = 2
      ELSEIF ( Mode==2 ) THEN
!     only compute pmn for n-m even
         ms = M + 1
         ninc = 2
      ENDIF
 
 
      IF ( M>1 ) THEN
         DO np1 = ms , Nlat , ninc
            n = np1 - 1
            imn = INDX(M,n)
            IF ( n>=L ) imn = IMNDX(M,n)
            DO i = 1 , Late
               Pmn(np1,i,km0) = Abel(imn)*Pmn(n-1,i,km2) + Bbel(imn)    &
                              & *Pmn(n-1,i,km0) - Cbel(imn)             &
                              & *Pmn(np1,i,km2)
            ENDDO
         ENDDO
 
      ELSEIF ( M==0 ) THEN
         DO np1 = ms , Nlat , ninc
            DO i = 1 , Late
               Pmn(np1,i,km0) = P0n(np1,i)
            ENDDO
         ENDDO
 
      ELSEIF ( M==1 ) THEN
         DO np1 = ms , Nlat , ninc
            DO i = 1 , Late
               Pmn(np1,i,km0) = P1n(np1,i)
            ENDDO
         ENDDO
      ENDIF
 
!     permute column indices
!     km0,km1,km2 store m,m-1,m-2 columns
      kmt = km0
      km0 = km2
      km2 = km1
      km1 = kmt
!     set current m index in output param km
      Km = kmt
      END SUBROUTINE LEGIN1
 
 
      SUBROUTINE ZFIN(Isym,Nlat,Nlon,M,Z,I3,Wzfin)
      IMPLICIT NONE
      INTEGER I3 , imid , Isym , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL Wzfin , Z
      DIMENSION Z(1) , Wzfin(1)
      imid = (Nlat+1)/2
      lim = Nlat*imid
      mmax = MIN0(Nlat,Nlon/2+1)
      labc = ((mmax-2)*(Nlat+Nlat-mmax-1))/2
      iw1 = lim + 1
      iw2 = iw1 + lim
      iw3 = iw2 + labc
      iw4 = iw3 + labc
!
!     the length of wzfin is 2*lim+3*labc
!
      CALL ZFIN1(Isym,Nlat,M,Z,imid,I3,Wzfin,Wzfin(iw1),Wzfin(iw2),     &
               & Wzfin(iw3),Wzfin(iw4))
      END SUBROUTINE ZFIN


      SUBROUTINE ZFIN1(Isym,Nlat,M,Z,Imid,I3,Zz,Z1,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , Z , Z1 , Zz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Isym , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Z(Imid,Nlat,3) , Zz(Imid,1) , Z1(Imid,1) , A(1) , B(1) ,&
              & C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Z(i,np1,I3) = Zz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Z(i,np1,I3) = Z1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Isym/=1 ) THEN
            DO i = 1 , Imid
               Z(i,M+1,I3) = A(ns)*Z(i,M-1,i1) - C(ns)*Z(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Isym/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Z(i,M+2,I3) = A(ns)*Z(i,M,i1) - C(ns)*Z(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Isym==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Isym==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Z(i,np1,I3) = A(ns)*Z(i,np1-2,i1) + B(ns)             &
                              & *Z(i,np1-2,I3) - C(ns)*Z(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE ZFIN1


      SUBROUTINE ZFINIT(Nlat,Nlon,Wzfin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wzfin
      DIMENSION Wzfin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzfin is 3*((l-3)*l+2)/2 + 2*l*imid
!     the length of dwork is nlat+1
!
      CALL ZFINI1(Nlat,Nlon,imid,Wzfin,Wzfin(iw1),Dwork,Dwork(imid+1))
      END SUBROUTINE ZFINIT


      SUBROUTINE ZFINI1(Nlat,Nlon,Imid,Z,Abc,Cz,Work)
      IMPLICIT NONE
      REAL Abc , Z
      INTEGER i , Imid , m , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations
!     where mmax = min0(nlat,nlon/2+1)
!     cz and work must each have nlat+1 locations
!
      DIMENSION Z(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , th , zh , Cz(*) , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      DO mp1 = 1 , 2
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DNZFK(Nlat,m,n,Cz,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DNZFT(Nlat,m,n,th,Cz,zh)
               Z(i,np1,mp1) = zh
            ENDDO
            Z(1,np1,mp1) = .5*Z(1,np1,mp1)
         ENDDO
      ENDDO
      CALL RABCP(Nlat,Nlon,Abc)
      END SUBROUTINE ZFINI1


      SUBROUTINE DNZFK(Nlat,M,N,Cz,Work)
      IMPLICIT NONE
      INTEGER i , idx , k , kdo , kp1 , lc , M , mmod , N , Nlat , nmod
!
!     dnzfk computes the coefficients in the trigonometric
!     expansion of the z functions that are used in spherical
!     harmonic analysis.
!
      DIMENSION Cz(1) , Work(1)
!
!     cz and work must both have nlat+1 locations
!
      DOUBLE PRECISION sum , sc1 , t1 , t2 , Work , Cz
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DNLFK(M,N,Work)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod<=0 ) THEN
         IF ( mmod<=0 ) THEN
!
!     n even, m even
!
            kdo = N/2 + 1
            DO idx = 1 , lc
               i = idx + idx - 2
               sum = Work(1)/(1.D0-i*i)
               IF ( kdo>=2 ) THEN
                  DO 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)
                  ENDDO
               ENDIF
               Cz(idx) = sc1*sum
            ENDDO
            RETURN
         ELSE
!
!     n even, m odd
!
            kdo = N/2
            DO idx = 1 , lc
               i = idx + idx - 2
               sum = 0.
               DO 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)
               ENDDO
               Cz(idx) = sc1*sum
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod<=0 ) THEN
!
!     n odd, m even
!
         kdo = (N+1)/2
         DO idx = 1 , lc
            i = idx + idx - 1
            sum = 0.
            DO 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)
            ENDDO
            Cz(idx) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n odd, m odd
!
         kdo = (N+1)/2
         DO idx = 1 , lc
            i = idx + idx - 3
            sum = 0.
            DO 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)
            ENDDO
            Cz(idx) = sc1*sum
         ENDDO
      ENDIF
      END SUBROUTINE DNZFK


      SUBROUTINE DNZFT(Nlat,M,N,Th,Cz,Zh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
      DIMENSION Cz(1)
      DOUBLE PRECISION Cz , Zh , Th , cdt , sdt , cth , sth , chh
      Zh = 0.
      cdt = DCOS(Th+Th)
      sdt = DSIN(Th+Th)
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod<=0 ) THEN
         lc = Nlat/2
         lq = lc - 1
         IF ( nmod<=0 ) THEN
            IF ( mmod<=0 ) THEN
!
!     nlat even n even m even
!
               Zh = .5*Cz(1)
               cth = cdt
               sth = sdt
               DO k = 2 , lc
!     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
               ENDDO
               RETURN
            ELSE
!
!     nlat even n even m odd
!
               cth = cdt
               sth = sdt
               DO k = 1 , lq
!     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
               ENDDO
               RETURN
            ENDIF
!
!     nlat even n odd m even
!
         ELSEIF ( mmod<=0 ) THEN
            Zh = .5*Cz(lc)*DCOS((Nlat-1)*Th)
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            RETURN
         ELSE
!
!     nlat even n odd m odd
!
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         lc = (Nlat+1)/2
         lq = lc - 1
         ls = lc - 2
         IF ( nmod<=0 ) THEN
            IF ( mmod<=0 ) THEN
!
!     nlat odd n even m even
!
               Zh = .5*(Cz(1)+Cz(lc)*DCOS(2*lq*Th))
               cth = cdt
               sth = sdt
               DO k = 2 , lq
!     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
               ENDDO
               RETURN
            ELSE
!
!     nlat odd n even m odd
!
               cth = cdt
               sth = sdt
               DO k = 1 , ls
!     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
               ENDDO
               RETURN
            ENDIF
!
!     nlat odd n odd, m even
!
         ELSEIF ( mmod<=0 ) THEN
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     nlat odd n odd m odd
!
      cth = DCOS(Th)
      sth = DSIN(Th)
      DO k = 1 , lq
!     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
      ENDDO
      RETURN
99999 END SUBROUTINE DNZFT


      SUBROUTINE ALIN(Isym,Nlat,Nlon,M,P,I3,Walin)
      IMPLICIT NONE
      INTEGER I3 , imid , Isym , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL P , Walin
      DIMENSION P(1) , Walin(1)
      imid = (Nlat+1)/2
      lim = Nlat*imid
      mmax = MIN0(Nlat,Nlon/2+1)
      labc = ((mmax-2)*(Nlat+Nlat-mmax-1))/2
      iw1 = lim + 1
      iw2 = iw1 + lim
      iw3 = iw2 + labc
      iw4 = iw3 + labc
!
!     the length of walin is ((5*l-7)*l+6)/2
!
      CALL ALIN1(Isym,Nlat,M,P,imid,I3,Walin,Walin(iw1),Walin(iw2),     &
               & Walin(iw3),Walin(iw4))
      END SUBROUTINE ALIN


      SUBROUTINE ALIN1(Isym,Nlat,M,P,Imid,I3,Pz,P1,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , P , P1 , Pz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Isym , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION P(Imid,Nlat,3) , Pz(Imid,1) , P1(Imid,1) , A(1) , B(1) ,&
              & C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               P(i,np1,I3) = Pz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               P(i,np1,I3) = P1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Isym/=1 ) THEN
            DO i = 1 , Imid
               P(i,M+1,I3) = A(ns)*P(i,M-1,i1) - C(ns)*P(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Isym/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               P(i,M+2,I3) = A(ns)*P(i,M,i1) - C(ns)*P(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Isym==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Isym==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  P(i,np1,I3) = A(ns)*P(i,np1-2,i1) + B(ns)             &
                              & *P(i,np1-2,I3) - C(ns)*P(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE ALIN1


      SUBROUTINE ALINIT(Nlat,Nlon,Walin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Walin
      DIMENSION Walin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of walin is 3*((l-3)*l+2)/2 + 2*l*imid
!     the length of work is nlat+1
!
      CALL ALINI1(Nlat,Nlon,imid,Walin,Walin(iw1),Dwork)
      END SUBROUTINE ALINIT


      SUBROUTINE ALINI1(Nlat,Nlon,Imid,P,Abc,Cp)
      IMPLICIT NONE
      REAL Abc , P
      INTEGER i , Imid , m , mp1 , n , Nlat , Nlon , np1
      DIMENSION P(Imid,Nlat,2) , Abc(1) , Cp(1)
      DOUBLE PRECISION pi , dt , th , Cp , ph
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      DO mp1 = 1 , 2
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DNLFK(m,n,Cp)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DNLFT(m,n,th,Cp,ph)
               P(i,np1,mp1) = ph
            ENDDO
         ENDDO
      ENDDO
      CALL RABCP(Nlat,Nlon,Abc)
      END SUBROUTINE ALINI1

      
      SUBROUTINE RABCP(Nlat,Nlon,Abc)
      IMPLICIT NONE
      REAL Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcp computes the coefficients in the recurrence
!     relation for the associated legendre fuctions. array abc
!     must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations.
!
      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))
      END SUBROUTINE RABCP


      SUBROUTINE RABCP1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!
!     coefficients a, b, and c for computing pbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 3 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         A(ns) = SQRT((tm+1.)*(tm-2.)/temp)
         C(ns) = SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            A(ns) = SQRT((tm+3.)*(tm-2.)/temp)
            C(ns) = SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  A(ns) = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE RABCP1

      
      SUBROUTINE SEA1(Nlat,Nlon,Imid,Z,Idz,Zin,Wzfin,Dwork)
      IMPLICIT NONE
      INTEGER i , i3 , Idz , Imid , m , mmax , mn , mp1 , Nlat , Nlon , &
            & np1
      REAL Wzfin , Z , Zin
      DIMENSION Z(Idz,*) , Zin(Imid,Nlat,3) , Wzfin(*)
      DOUBLE PRECISION Dwork(*)
      CALL ZFINIT(Nlat,Nlon,Wzfin,Dwork)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 1 , mmax
         m = mp1 - 1
         CALL ZFIN(0,Nlat,Nlon,m,Zin,i3,Wzfin)
         DO np1 = mp1 , Nlat
            mn = m*(Nlat-1) - (m*(m-1))/2 + np1
            DO i = 1 , Imid
               Z(mn,i) = Zin(i,np1,i3)
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE SEA1


      SUBROUTINE SES1(Nlat,Nlon,Imid,P,Pin,Walin,Dwork)
      IMPLICIT NONE
      INTEGER i , i3 , Imid , m , mmax , mn , mp1 , Nlat , Nlon , np1
      REAL P , Pin , Walin
      DIMENSION P(Imid,*) , Pin(Imid,Nlat,3) , Walin(*)
      DOUBLE PRECISION Dwork(*)
      CALL ALINIT(Nlat,Nlon,Walin,Dwork)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 1 , mmax
         m = mp1 - 1
         CALL ALIN(0,Nlat,Nlon,m,Pin,i3,Walin)
         DO np1 = mp1 , Nlat
            mn = m*(Nlat-1) - (m*(m-1))/2 + np1
            DO i = 1 , Imid
               P(i,mn) = Pin(i,np1,i3)
            ENDDO
         ENDDO
      ENDDO
    END SUBROUTINE  SES1


      SUBROUTINE ZVINIT(Nlat,Nlon,Wzvin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wzvin
      DIMENSION Wzvin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzvin is
!         2*nlat*imid +3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     the length of dwork is 2*nlat+2
!
      CALL ZVINI1(Nlat,Nlon,imid,Wzvin,Wzvin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE ZVINIT


      SUBROUTINE ZVINI1(Nlat,Nlon,Imid,Zv,Abc,Czv,Work)
      IMPLICIT NONE
      REAL Abc , Zv
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     czv and work must each have nlat+1  locations
!
      DIMENSION Zv(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Czv(1) , zvh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DZVK(Nlat,m,n,Czv,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DZVT(Nlat,m,n,th,Czv,zvh)
               Zv(i,np1,mp1) = zvh
            ENDDO
            Zv(1,np1,mp1) = .5*Zv(1,np1,mp1)
         ENDDO
      ENDDO
      CALL RABCV(Nlat,Nlon,Abc)
      END SUBROUTINE ZVINI1


      SUBROUTINE ZWINIT(Nlat,Nlon,Wzwin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wzwin
      DIMENSION Wzwin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzvin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL ZWINI1(Nlat,Nlon,imid,Wzwin,Wzwin(iw1),Dwork,Dwork(Nlat+2))
    END SUBROUTINE ZWINIT
    

      SUBROUTINE ZWINI1(Nlat,Nlon,Imid,Zw,Abc,Czw,Work)
      IMPLICIT NONE
      REAL Abc , Zw
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     czw and work must each have nlat+1 locations
!
      DIMENSION Zw(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Czw(1) , zwh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DZWK(Nlat,m,n,Czw,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DZWT(Nlat,m,n,th,Czw,zwh)
               Zw(i,np1,m) = zwh
            ENDDO
            Zw(1,np1,m) = .5*Zw(1,np1,m)
         ENDDO
      ENDDO
      CALL RABCW(Nlat,Nlon,Abc)
      END SUBROUTINE ZWINI1


      SUBROUTINE ZVIN(Ityp,Nlat,Nlon,M,Zv,I3,Wzvin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL Wzvin , Zv
      DIMENSION Zv(1) , Wzvin(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
!
!     the length of wzvin is 2*lim+3*labc
!
      CALL ZVIN1(Ityp,Nlat,M,Zv,imid,I3,Wzvin,Wzvin(iw1),Wzvin(iw2),    &
               & Wzvin(iw3),Wzvin(iw4))
      END SUBROUTINE ZVIN


      SUBROUTINE ZVIN1(Ityp,Nlat,M,Zv,Imid,I3,Zvz,Zv1,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , Zv , Zv1 , Zvz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Zv(Imid,Nlat,3) , Zvz(Imid,1) , Zv1(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Zv(i,np1,I3) = Zvz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Zv(i,np1,I3) = Zv1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Zv(i,M+1,I3) = A(ns)*Zv(i,M-1,i1) - C(ns)*Zv(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Zv(i,M+2,I3) = A(ns)*Zv(i,M,i1) - C(ns)*Zv(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Zv(i,np1,I3) = A(ns)*Zv(i,np1-2,i1) + B(ns)           &
                               & *Zv(i,np1-2,I3) - C(ns)*Zv(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE ZVIN1


      SUBROUTINE ZWIN(Ityp,Nlat,Nlon,M,Zw,I3,Wzwin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL Wzwin , Zw
      DIMENSION Zw(1) , Wzwin(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
!
!     the length of wzwin is 2*lim+3*labc
!
      CALL ZWIN1(Ityp,Nlat,M,Zw,imid,I3,Wzwin,Wzwin(iw1),Wzwin(iw2),    &
               & Wzwin(iw3),Wzwin(iw4))
      END SUBROUTINE ZWIN


      SUBROUTINE ZWIN1(Ityp,Nlat,M,Zw,Imid,I3,Zw1,Zw2,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , Zw , Zw1 , Zw2
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Zw(Imid,Nlat,3) , Zw1(Imid,1) , Zw2(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<2 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Zw(i,np1,I3) = Zw1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==2 ) THEN
         DO np1 = 3 , Nlat
            DO i = 1 , Imid
               Zw(i,np1,I3) = Zw2(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Zw(i,M+1,I3) = A(ns)*Zw(i,M-1,i1) - C(ns)*Zw(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Zw(i,M+2,I3) = A(ns)*Zw(i,M,i1) - C(ns)*Zw(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Zw(i,np1,I3) = A(ns)*Zw(i,np1-2,i1) + B(ns)           &
                               & *Zw(i,np1-2,I3) - C(ns)*Zw(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END  SUBROUTINE ZWIN1


      SUBROUTINE VBINIT(Nlat,Nlon,Wvbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wvbin
      DIMENSION Wvbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL VBINI1(Nlat,Nlon,imid,Wvbin,Wvbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE VBINIT


      SUBROUTINE VBINI1(Nlat,Nlon,Imid,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      REAL Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cvb(1) , th , vbh , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DVBK(m,n,Cvb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DVBT(m,n,th,Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCV(Nlat,Nlon,Abc)
      END SUBROUTINE VBINI1


      SUBROUTINE WBINIT(Nlat,Nlon,Wwbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL WBINI1(Nlat,Nlon,imid,Wwbin,Wwbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE WBINIT

      
      SUBROUTINE WBINI1(Nlat,Nlon,Imid,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      REAL Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cwb(1) , wbh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DWBK(m,n,Cwb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DWBT(m,n,th,Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCW(Nlat,Nlon,Abc)
      END SUBROUTINE WBINI1


      SUBROUTINE VBIN(Ityp,Nlat,Nlon,M,Vb,I3,Wvbin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL Vb , Wvbin
      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
!
!     the length of wvbin is 2*lim+3*labc
!
      CALL VBIN1(Ityp,Nlat,M,Vb,imid,I3,Wvbin,Wvbin(iw1),Wvbin(iw2),    &
               & Wvbin(iw3),Wvbin(iw4))
      END SUBROUTINE VBIN


      SUBROUTINE VBIN1(Ityp,Nlat,M,Vb,Imid,I3,Vbz,Vb1,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , Vb , Vb1 , Vbz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Vb(Imid,Nlat,3) , Vbz(Imid,1) , Vb1(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Vb(i,np1,I3) = Vbz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Vb(i,np1,I3) = Vb1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Vb(i,M+1,I3) = A(ns)*Vb(i,M-1,i1) - C(ns)*Vb(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Vb(i,M+2,I3) = A(ns)*Vb(i,M,i1) - C(ns)*Vb(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Vb(i,np1,I3) = A(ns)*Vb(i,np1-2,i1) + B(ns)           &
                               & *Vb(i,np1-2,I3) - C(ns)*Vb(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE VBIN1


      SUBROUTINE WBIN(Ityp,Nlat,Nlon,M,Wb,I3,Wwbin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      REAL Wb , Wwbin
      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
!
!     the length of wwbin is 2*lim+3*labc
!
      CALL WBIN1(Ityp,Nlat,M,Wb,imid,I3,Wwbin,Wwbin(iw1),Wwbin(iw2),    &
               & Wwbin(iw3),Wwbin(iw4))
      END SUBROUTINE WBIN

      
      SUBROUTINE WBIN1(Ityp,Nlat,M,Wb,Imid,I3,Wb1,Wb2,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , Wb , Wb1 , Wb2
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Wb(Imid,Nlat,3) , Wb1(Imid,1) , Wb2(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<2 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Wb(i,np1,I3) = Wb1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==2 ) THEN
         DO np1 = 3 , Nlat
            DO i = 1 , Imid
               Wb(i,np1,I3) = Wb2(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Wb(i,M+1,I3) = A(ns)*Wb(i,M-1,i1) - C(ns)*Wb(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Wb(i,M+2,I3) = A(ns)*Wb(i,M,i1) - C(ns)*Wb(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Wb(i,np1,I3) = A(ns)*Wb(i,np1-2,i1) + B(ns)           &
                               & *Wb(i,np1-2,I3) - C(ns)*Wb(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE WBIN1


      SUBROUTINE DZVK(Nlat,M,N,Czv,Work)
      IMPLICIT NONE
      INTEGER i , id , k , kdo , lc , M , mmod , N , Nlat , nmod
!
!     subroutine dzvk computes the coefficients in the trigonometric
!     expansion of the quadrature function zvbar(n,m,theta)
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of wbarv(n,m,theta)
!
!     m      the order (superscript) of wbarv(n,m,theta)
!
!     work   a work array with at least (nlat+1)/2 locations
!
!     output parameter
!
!     czv     the fourier coefficients of zvbar(n,m,theta).
!
      DIMENSION Czv(1) , Work(1)
      DOUBLE PRECISION Czv , sc1 , sum , Work , t1 , t2
      IF ( N<=0 ) RETURN
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DVBK(M,N,Work,Czv)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     n odd, m odd
!
            kdo = (N+1)/2
            DO id = 1 , lc
               i = id + id - 1
               sum = 0.
               DO 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)
               ENDDO
               Czv(id) = sc1*sum
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even, m odd
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 2
            sum = 0.
            DO 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)
            ENDDO
            Czv(id) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n even, m even
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 2
            sum = 0.
            DO 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)
            ENDDO
            Czv(id) = sc1*sum
         ENDDO
         RETURN
      ENDIF
!
!     n odd, m even
!
      kdo = (N+1)/2
      DO id = 1 , lc
         i = id + id - 3
         sum = 0.
         DO 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)
         ENDDO
         Czv(id) = sc1*sum
      ENDDO
      RETURN
99999 END SUBROUTINE DZVK


      SUBROUTINE DZVT(Nlat,M,N,Th,Czv,Zvh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
!
!     subroutine dzvt tabulates the function zvbar(n,m,theta)
!     at theta = th in double precision
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of zvbar(n,m,theta)
!
!     m      the order (superscript) of zvbar(n,m,theta)
!
!     czv     the fourier coefficients of zvbar(n,m,theta)
!             as computed by subroutine zwk.
!
!     output parameter
!
!     zvh     zvbar(m,n,theta) evaluated at theta = th
!
      DIMENSION Czv(1)
      DOUBLE PRECISION Th , Czv , Zvh , cth , sth , cdt , sdt , chh
      Zvh = 0.
      IF ( N<=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.*sth*cth
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod==0 ) THEN
         IF ( nmod==0 ) THEN
            cth = cdt
            sth = sdt
            IF ( mmod/=0 ) THEN
!
!     nlat even  n even  m odd
!
               Zvh = .5*Czv(1)
               DO k = 2 , lc
                  Zvh = Zvh + Czv(k)*cth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               RETURN
            ELSE
!
!     nlat even  n even  m even
!
               DO k = 1 , lq
                  Zvh = Zvh + Czv(k+1)*sth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               RETURN
            ENDIF
         ELSEIF ( mmod/=0 ) THEN
!
!     nlat even  n odd  m odd
!
            Zvh = .5*Czv(lc)*DCOS((Nlat-1)*Th)
            DO k = 1 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n odd  m odd
!
            DO k = 1 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     nlat odd  n odd  m even
!
            DO k = 1 , lq
               Zvh = Zvh + Czv(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSE
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n even  m odd
!
            Zvh = .5*Czv(1)
            DO k = 2 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            Zvh = Zvh + .5*Czv(lc)*DCOS((Nlat-1)*Th)
            RETURN
         ELSE
!
!     nlat odd  n even  m even
!
            DO k = 1 , ls
               Zvh = Zvh + Czv(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     nlat even  n odd  m even
!
      DO k = 1 , lq
         Zvh = Zvh + Czv(k+1)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DZVT

      
      SUBROUTINE DZWK(Nlat,M,N,Czw,Work)
      IMPLICIT NONE
      INTEGER i , id , k , kdo , kp1 , lc , M , mmod , N , Nlat , nmod
!
!     subroutine dzwk computes the coefficients in the trigonometric
!     expansion of the quadrature function zwbar(n,m,theta)
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of zwbar(n,m,theta)
!
!     m      the order (superscript) of zwbar(n,m,theta)
!
!     work   a work array with at least (nlat+1)/2 locations
!
!     output parameter
!
!     czw     the fourier coefficients of zwbar(n,m,theta).
!
      DIMENSION Czw(1) , Work(1)
      DOUBLE PRECISION Czw , Work , sc1 , sum , t1 , t2
      IF ( N<=0 ) RETURN
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DWBK(M,N,Work,Czw)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     n odd, m odd
!
            kdo = (N+1)/2
            DO id = 1 , lc
               i = id + id - 2
               sum = Work(1)/(1.D0-i*i)
               IF ( kdo>=2 ) THEN
                  DO 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)
                  ENDDO
               ENDIF
               Czw(id) = sc1*sum
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even, m odd
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 1
            sum = 0.
            DO 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)
            ENDDO
            Czw(id) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n even, m even
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 3
            sum = 0.
            DO 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)
            ENDDO
            Czw(id) = sc1*sum
         ENDDO
         RETURN
      ENDIF
!
!     n odd, m even
!
      kdo = (N-1)/2
      DO id = 1 , lc
         i = id + id - 2
         sum = 0.
         DO 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)
         ENDDO
         Czw(id) = sc1*sum
      ENDDO
      RETURN
99999 END SUBROUTINE DZWK


      SUBROUTINE DZWT(Nlat,M,N,Th,Czw,Zwh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
!
!     subroutine dzwt tabulates the function zwbar(n,m,theta)
!     at theta = th in double precision
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!            nlat must be an odd integer
!
!     n      the degree (subscript) of zwbar(n,m,theta)
!
!     m      the order (superscript) of zwbar(n,m,theta)
!
!     czw     the fourier coefficients of zwbar(n,m,theta)
!             as computed by subroutine zwk.
!
!     output parameter
!
!     zwh     zwbar(m,n,theta) evaluated at theta = th
!
      DIMENSION Czw(1)
      DOUBLE PRECISION Czw , Zwh , Th , cth , sth , cdt , sdt , chh
      Zwh = 0.
      IF ( N<=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.*sth*cth
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod==0 ) THEN
         IF ( nmod/=0 ) THEN
            cth = cdt
            sth = sdt
            IF ( mmod/=0 ) THEN
!
!     nlat even  n odd  m odd
!
               Zwh = .5*Czw(1)
               DO k = 2 , lc
                  Zwh = Zwh + Czw(k)*cth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               GOTO 99999
            ENDIF
         ELSEIF ( mmod/=0 ) THEN
!
!     nlat even  n even  m odd
!
            Zwh = .5*Czw(lc)*DCOS((Nlat-1)*Th)
            DO k = 1 , lq
               Zwh = Zwh + Czw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     nlat even  n even  m even
!
            DO k = 1 , lq
               Zwh = Zwh + Czw(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n odd  m odd
!
            Zwh = .5*Czw(1)
            DO k = 2 , lq
               Zwh = Zwh + Czw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            Zwh = Zwh + .5*Czw(lc)*DCOS((Nlat-1)*Th)
            RETURN
         ELSE
!
!     nlat odd  n odd  m even
!
            DO k = 1 , ls
               Zwh = Zwh + Czw(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     nlat odd  n even  m odd
!
         DO k = 1 , lq
            Zwh = Zwh + Czw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     nlat odd  n even  m even
!
         DO k = 1 , lq
            Zwh = Zwh + Czw(k+1)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     nlat even  n odd  m even
!
      DO k = 1 , lq
         Zwh = Zwh + Czw(k+1)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DZWT


      SUBROUTINE DVBK(M,N,Cv,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N , ncv
      REAL srnp1
      DOUBLE PRECISION Cv(1) , Work(1) , fn , fk , cf
      Cv(1) = 0.
      IF ( N<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DNLFK(M,N,Work)
      IF ( modn/=0 ) THEN
         ncv = (N+1)/2
         fk = -1.
         IF ( modm/=0 ) THEN
!
!     n odd m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = fk*Work(l)/srnp1
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         ncv = N/2
         IF ( ncv==0 ) RETURN
         fk = 0.
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = fk*Work(l)/srnp1
            ENDDO
            RETURN
         ELSE
!
!     n even m even
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*Work(l+1)/srnp1
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     n odd m even
!
      DO l = 1 , ncv
         fk = fk + 2.
         Cv(l) = -fk*Work(l)/srnp1
      ENDDO
      RETURN
99999 END SUBROUTINE DVBK


      SUBROUTINE DWBK(M,N,Cw,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N
      DOUBLE PRECISION Cw(1) , Work(1) , fn , cf , srnp1
      Cw(1) = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DNLFK(M,N,Work)
      IF ( M/=0 ) THEN
         IF ( modn==0 ) THEN
            l = N/2
            IF ( l/=0 ) THEN
               IF ( modm/=0 ) THEN
!
!     n even m odd
!
                  Cw(l) = cf*Work(l)
 5                l = l - 1
                  IF ( l>0 ) THEN
                     Cw(l) = Cw(l+1) + cf*Work(l)
                     GOTO 5
                  ENDIF
               ELSE
!
!     n even m even
!
                  Cw(l) = -cf*Work(l+1)
 10               l = l - 1
                  IF ( l>0 ) THEN
                     Cw(l) = Cw(l+1) - cf*Work(l+1)
                     GOTO 10
                  ENDIF
               ENDIF
            ENDIF
         ELSEIF ( modm/=0 ) THEN
!
!     n odd m odd
!
            l = (N+1)/2
            Cw(l) = cf*Work(l)
 20         l = l - 1
            IF ( l>0 ) THEN
               Cw(l) = Cw(l+1) + cf*Work(l)
               GOTO 20
            ENDIF
         ELSE
            l = (N-1)/2
            IF ( l/=0 ) THEN
!
!     n odd m even
!
               Cw(l) = -cf*Work(l+1)
 30            l = l - 1
               IF ( l>0 ) THEN
                  Cw(l) = Cw(l+1) - cf*Work(l+1)
                  GOTO 30
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      END SUBROUTINE DWBK


      SUBROUTINE DVBT(M,N,Theta,Cv,Vh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncv , nmod
      DIMENSION Cv(1)
      DOUBLE PRECISION Cv , Vh , Theta , cth , sth , cdt , sdt , chh
      Vh = 0.
      IF ( N==0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod==0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     n even  m odd
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     n even  m even
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
         ncv = (N+1)/2
         DO k = 1 , ncv
            Vh = Vh + Cv(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         GOTO 99999
      ENDIF
!
!     n odd m even
!
      ncv = (N+1)/2
      DO k = 1 , ncv
         Vh = Vh + Cv(k)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DVBT


      SUBROUTINE DWBT(M,N,Theta,Cw,Wh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncw , nmod
      DIMENSION Cw(1)
      DOUBLE PRECISION Theta , Cw , Wh , cth , sth , cdt , sdt , chh
      Wh = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
            ncw = (N+1)/2
            Wh = .5*Cw(1)
            IF ( ncw<2 ) RETURN
            DO k = 2 , ncw
               Wh = Wh + Cw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even  m odd
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     n even  m even
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     n odd m even
!
      ncw = (N-1)/2
      DO k = 1 , ncw
         Wh = Wh + Cw(k)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DWBT


      SUBROUTINE RABCV(Nlat,Nlon,Abc)
      IMPLICIT NONE
      REAL Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcp computes the coefficients in the recurrence
!     relation for the functions vbar(m,n,theta). array abc
!     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
!
      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))
      END SUBROUTINE RABCV

      
      SUBROUTINE RABCV1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn , tpn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!
!     coefficients a, b, and c for computing vbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( mmax<3 ) RETURN
      DO mp1 = 3 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.))
         A(ns) = SQRT(tpn*(tm+1.)*(tm-2.)/temp)
         C(ns) = SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            tpn = (fm-1.)*fm/((fm+1.)*(fm+2.))
            A(ns) = SQRT(tpn*(tm+3.)*(tm-2.)/temp)
            C(ns) = SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.))
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  A(ns) = SQRT(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(tpn*cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE RABCV1


      SUBROUTINE RABCW(Nlat,Nlon,Abc)
      IMPLICIT NONE
      REAL Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcw computes the coefficients in the recurrence
!     relation for the functions wbar(m,n,theta). array abc
!     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
!
      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))
      END SUBROUTINE RABCW


      SUBROUTINE RABCW1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      REAL A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn ,    &
         & tph , tpn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!*** End of declarations inserted by SPAG
!
!     coefficients a, b, and c for computing wbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( mmax<4 ) RETURN
      DO mp1 = 4 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.))
         tph = fm/(fm-2.)
         A(ns) = tph*SQRT(tpn*(tm+1.)*(tm-2.)/temp)
         C(ns) = tph*SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            tpn = (fm-1.)*fm/((fm+1.)*(fm+2.))
            tph = fm/(fm-2.)
            A(ns) = tph*SQRT(tpn*(tm+3.)*(tm-2.)/temp)
            C(ns) = tph*SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.))
                  tph = fm/(fm-2.)
                  A(ns) = tph*SQRT(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(tpn*cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = tph*SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE  RABCW1

      
      SUBROUTINE VTINIT(Nlat,Nlon,Wvbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wvbin
      DIMENSION Wvbin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL VTINI1(Nlat,Nlon,imid,Wvbin,Wvbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE VTINIT


      SUBROUTINE VTINI1(Nlat,Nlon,Imid,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      REAL Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1) , Cvb(1)
      DOUBLE PRECISION pi , dt , Cvb , th , vbh , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DVTK(m,n,Cvb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DVTT(m,n,th,Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCV(Nlat,Nlon,Abc)
      END SUBROUTINE VTINI1


      SUBROUTINE WTINIT(Nlat,Nlon,Wwbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL WTINI1(Nlat,Nlon,imid,Wwbin,Wwbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE WTINIT


      SUBROUTINE WTINI1(Nlat,Nlon,Imid,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      REAL Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cwb(*) , wbh , th , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DWTK(m,n,Cwb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DWTT(m,n,th,Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCW(Nlat,Nlon,Abc)
      END SUBROUTINE WTINI1


      SUBROUTINE VTGINT(Nlat,Nlon,Theta,Wvbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wvbin
      DIMENSION Wvbin(*)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL VTGIT1(Nlat,Nlon,imid,Theta,Wvbin,Wvbin(iw1),Work,           &
                & Work(Nlat+2))
!    1                        work,work(2*nlat+3))
      END SUBROUTINE VTGINT


      SUBROUTINE VTGIT1(Nlat,Nlon,Imid,Theta,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      REAL Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1   locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(*)
      DOUBLE PRECISION Theta(*) , Cvb(*) , Work(*) , vbh
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DVTK(m,n,Cvb,Work)
            DO i = 1 , Imid
               CALL DVTT(m,n,Theta(i),Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCV(Nlat,Nlon,Abc)
    END SUBROUTINE VTGIT1


      SUBROUTINE WTGINT(Nlat,Nlon,Theta,Wwbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wwbin
      DIMENSION Wwbin(*)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL WTGIT1(Nlat,Nlon,imid,Theta,Wwbin,Wwbin(iw1),Work,           &
                & Work(Nlat+2))
      END SUBROUTINE WTGINT


      SUBROUTINE WTGIT1(Nlat,Nlon,Imid,Theta,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      REAL Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((nlat-3)*nlat+2)/2 locations
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION Theta(*) , Cwb(*) , Work(*) , wbh
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DWTK(m,n,Cwb,Work)
            DO i = 1 , Imid
               CALL DWTT(m,n,Theta(i),Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCW(Nlat,Nlon,Abc)
      END SUBROUTINE WTGIT1


      SUBROUTINE DVTK(M,N,Cv,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N , ncv
      DOUBLE PRECISION Cv(*) , Work(*) , fn , fk , cf , srnp1
      Cv(1) = 0.
      IF ( N<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DNLFK(M,N,Work)
      IF ( modn/=0 ) THEN
         ncv = (N+1)/2
         fk = -1.
         IF ( modm/=0 ) THEN
!
!     n odd m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l)/srnp1
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         ncv = N/2
         IF ( ncv==0 ) RETURN
         fk = 0.
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l)/srnp1
            ENDDO
            RETURN
         ELSE
!
!     n even m even
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l+1)/srnp1
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     n odd m even
!
      DO l = 1 , ncv
         fk = fk + 2.
         Cv(l) = -fk*fk*Work(l)/srnp1
      ENDDO
      RETURN
99999 END SUBROUTINE DVTK


      SUBROUTINE DWTK(M,N,Cw,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N
      DOUBLE PRECISION Cw(*) , Work(*) , fn , cf , srnp1
      Cw(1) = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DNLFK(M,N,Work)
      IF ( M==0 ) GOTO 99999
      IF ( modn==0 ) THEN
         l = N/2
         IF ( l==0 ) GOTO 99999
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            Cw(l) = cf*Work(l)
         ELSE
!
!     n even m even
!
            Cw(l) = -cf*Work(l+1)
 20         l = l - 1
            IF ( l<=0 ) GOTO 99999
            Cw(l) = Cw(l+1) - cf*Work(l+1)
            Cw(l+1) = (l+l+1)*Cw(l+1)
            GOTO 20
         ENDIF
      ELSEIF ( modm/=0 ) THEN
!
!     n odd m odd
!
         l = (N+1)/2
         Cw(l) = cf*Work(l)
         GOTO 300
      ELSE
         l = (N-1)/2
         IF ( l==0 ) GOTO 99999
!
!     n odd m even
!
         Cw(l) = -cf*Work(l+1)
         GOTO 200
      ENDIF
 100  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) + cf*Work(l)
      Cw(l+1) = -(l+l+1)*Cw(l+1)
      GOTO 100
 200  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) - cf*Work(l+1)
      Cw(l+1) = (l+l+2)*Cw(l+1)
      GOTO 200
 300  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) + cf*Work(l)
      Cw(l+1) = -(l+l)*Cw(l+1)
      GOTO 300
99999 END


      SUBROUTINE DVTT(M,N,Theta,Cv,Vh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncv , nmod
      DIMENSION Cv(1)
      DOUBLE PRECISION Cv , Vh , Theta , cth , sth , cdt , sdt , chh
      Vh = 0.
      IF ( N==0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod==0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     n even  m odd
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     n even  m even
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
         ncv = (N+1)/2
         DO k = 1 , ncv
            Vh = Vh + Cv(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         GOTO 99999
      ENDIF
!
!     n odd m even
!
      ncv = (N+1)/2
      DO k = 1 , ncv
         Vh = Vh + Cv(k)*cth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DVTT


      SUBROUTINE DWTT(M,N,Theta,Cw,Wh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncw , nmod
      DIMENSION Cw(1)
      DOUBLE PRECISION Theta , Cw , Wh , cth , sth , cdt , sdt , chh
      Wh = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
            ncw = (N+1)/2
            Wh = 0.
            IF ( ncw<2 ) RETURN
            DO k = 2 , ncw
               Wh = Wh + Cw(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even  m odd
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     n even  m even
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     n odd m even
!
      ncw = (N-1)/2
      DO k = 1 , ncw
         Wh = Wh + Cw(k)*cth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DWTT


      SUBROUTINE VBGINT(Nlat,Nlon,Theta,Wvbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wvbin
      DIMENSION Wvbin(1)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL VBGIT1(Nlat,Nlon,imid,Theta,Wvbin,Wvbin(iw1),Work,           &
                & Work(Nlat+2))
!    1                        work,work(2*nlat+3))
      END


      SUBROUTINE VBGIT1(Nlat,Nlon,Imid,Theta,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      REAL Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION Cvb(1) , Theta(1) , vbh , Work(1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DVBK(m,n,Cvb,Work)
            DO i = 1 , Imid
               CALL DVBT(m,n,Theta(i),Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCV(Nlat,Nlon,Abc)
      END SUBROUTINE VBGIT1


      SUBROUTINE WBGINT(Nlat,Nlon,Theta,Wwbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      REAL Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Work(*) , Theta(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL WBGIT1(Nlat,Nlon,imid,Theta,Wwbin,Wwbin(iw1),Work,           &
                & Work(Nlat+2))
      END

      
      SUBROUTINE WBGIT1(Nlat,Nlon,Imid,Theta,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      REAL Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((nlat-3)*nlat+2)/2 locations
!     cwb and work must each have nlat+1 locations
!
      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<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DWBK(m,n,Cwb,Work)
            DO i = 1 , Imid
               CALL DWBT(m,n,Theta(i),Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL RABCW(Nlat,Nlon,Abc)
    END SUBROUTINE WBGIT1


    SUBROUTINE DDNLFK(M,N,Cp)
      IMPLICIT NONE
      INTEGER i , l , M , ma , N , nex , nmms2
!
      DOUBLE PRECISION Cp , fnum , fden , fnmh , a1 , b1 , c1 , cp2 ,   &
                     & fnnp1 , fnmsq , fk , t1 , t2 , pm1 , SC10 ,      &
                     & SC20 , SC40
      DIMENSION Cp(1)
      PARAMETER (SC10=1024.D0)
      PARAMETER (SC20=SC10*SC10)
      PARAMETER (SC40=SC20*SC20)
!
      Cp(1) = 0.
      ma = IABS(M)
      IF ( ma>N ) RETURN
      IF ( N<1 ) THEN
         Cp(1) = DSQRT(2.D0)
         RETURN
      ELSEIF ( N==1 ) THEN
         IF ( ma/=0 ) THEN
            Cp(1) = DSQRT(.75D0)
            IF ( M==-1 ) Cp(1) = -Cp(1)
            RETURN
         ELSE
            Cp(1) = DSQRT(1.5D0)
            RETURN
         ENDIF
      ELSE
         IF ( MOD(N+ma,2)/=0 ) THEN
            nmms2 = (N-ma-1)/2
            fnum = N + ma + 2
            fnmh = N - ma + 2
            pm1 = -1.D0
         ELSE
            nmms2 = (N-ma)/2
            fnum = N + ma + 1
            fnmh = N - ma + 1
            pm1 = 1.D0
         ENDIF
!      t1 = 1.
!      t1 = 2.d0**(n-1)
!      t1 = 1.d0/t1
         t1 = 1.D0/SC20
         nex = 20
         fden = 2.D0
         IF ( nmms2>=1 ) THEN
            DO i = 1 , nmms2
               t1 = fnum*t1/fden
               IF ( t1>SC20 ) THEN
                  t1 = t1/SC40
                  nex = nex + 40
               ENDIF
               fnum = fnum + 2.
               fden = fden + 2.
            ENDDO
         ENDIF
         t1 = t1/2.D0**(N-1-nex)
         IF ( MOD(ma/2,2)/=0 ) t1 = -t1
         t2 = 1.
         IF ( ma/=0 ) THEN
            DO i = 1 , ma
               t2 = fnmh*t2/(fnmh+pm1)
               fnmh = fnmh + 2.
            ENDDO
         ENDIF
         cp2 = t1*DSQRT((N+.5D0)*t2)
         fnnp1 = N*(N+1)
         fnmsq = fnnp1 - 2.D0*ma*ma
         l = (N+1)/2
         IF ( MOD(N,2)==0 .AND. MOD(ma,2)==0 ) l = l + 1
         Cp(l) = cp2
         IF ( M<0 ) THEN
            IF ( MOD(ma,2)/=0 ) Cp(l) = -Cp(l)
         ENDIF
         IF ( l<=1 ) RETURN
         fk = N
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = 2.*(fk*fk-fnmsq)
         Cp(l-1) = b1*Cp(l)/a1
 50      l = l - 1
         IF ( l<=1 ) RETURN
         fk = fk - 2.
         a1 = (fk-2.)*(fk-1.) - fnnp1
         b1 = -2.*(fk*fk-fnmsq)
         c1 = (fk+1.)*(fk+2.) - fnnp1
         Cp(l-1) = -(b1*Cp(l)+c1*Cp(l+1))/a1
         GOTO 50
      ENDIF
      END SUBROUTINE DDNLFK


      SUBROUTINE DDNLFT(M,N,Theta,Cp,Pb)
      IMPLICIT NONE
      INTEGER k , kdo , M , mmod , N , nmod
      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<=0 ) THEN
         IF ( mmod<=0 ) THEN
!
!     n even, m even
!
            kdo = N/2
            Pb = .5*Cp(1)
            IF ( N==0 ) RETURN
            cth = cdt
            sth = sdt
            DO k = 1 , kdo
!     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
            ENDDO
            RETURN
         ELSE
!
!     n even, m odd
!
            kdo = N/2
            Pb = 0.
            cth = cdt
            sth = sdt
            DO k = 1 , kdo
!     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
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod<=0 ) THEN
!
!     n odd, m even
!
         kdo = (N+1)/2
         Pb = 0.
         cth = DCOS(Theta)
         sth = DSIN(Theta)
         DO k = 1 , kdo
!     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
         ENDDO
         RETURN
      ELSE
!
!     n odd, m odd
!
         kdo = (N+1)/2
         Pb = 0.
         cth = DCOS(Theta)
         sth = DSIN(Theta)
         DO k = 1 , kdo
!     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
         ENDDO
      ENDIF
      END SUBROUTINE DDNLFT


      SUBROUTINE DLEGIN(Mode,L,Nlat,M,W,Pmn,Km)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , Km , L , late , M , Mode , Nlat
      DOUBLE PRECISION Pmn , W
!     this subroutine computes legendre polynomials for n=m,...,l-1
!     and  i=1,...,late (late=((nlat+mod(nlat,2))/2)gaussian grid
!     in pmn(n+1,i,km) using swarztrauber's recursion formula.
!     the vector w contains quantities precomputed in shigc.
!     legin must be called in the order m=0,1,...,l-1
!     (e.g., if m=10 is sought it must be preceded by calls with
!     m=0,1,2,...,9 in that order)
      DIMENSION W(1) , Pmn(1)
!     set size of pole to equator gaussian grid
      late = (Nlat+MOD(Nlat,2))/2
!     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 DLEGIN1(Mode,L,Nlat,late,M,W(i1),W(i2),W(i3),W(i4),W(i5),Pmn, &
                & Km)
      END SUBROUTINE DLEGIN


      SUBROUTINE DLEGIN1(Mode,L,Nlat,Late,M,P0n,P1n,Abel,Bbel,Cbel,Pmn,  &
                      & Km)
      IMPLICIT NONE
      DOUBLE PRECISION Abel , Bbel , Cbel , P0n , P1n , Pmn
      INTEGER i , imn , IMNDX , INDX , Km , km0 , km1 , km2 , kmt , L , &
            & Late , M , Mode , ms , n , ninc , Nlat , np1
      DIMENSION P0n(Nlat,Late) , P1n(Nlat,Late)
      DIMENSION Abel(1) , Bbel(1) , Cbel(1) , Pmn(Nlat,Late,3)
      DATA km0 , km1 , km2/1 , 2 , 3/
      SAVE km0 , km1 , km2
!     define index function used in storing triangular
!     arrays for recursion coefficients (functions of (m,n))
!     for 2.le.m.le.n-1 and 2.le.n.le.l-1
      INDX(M,n) = (n-1)*(n-2)/2 + M - 1
!     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
 
!     set do loop indices for full or half sphere
      ms = M + 1
      ninc = 1
      IF ( Mode==1 ) THEN
!     only compute pmn for n-m odd
         ms = M + 2
         ninc = 2
      ELSEIF ( Mode==2 ) THEN
!     only compute pmn for n-m even
         ms = M + 1
         ninc = 2
      ENDIF
 
 
      IF ( M>1 ) THEN
         DO np1 = ms , Nlat , ninc
            n = np1 - 1
            imn = INDX(M,n)
            IF ( n>=L ) imn = IMNDX(M,n)
            DO i = 1 , Late
               Pmn(np1,i,km0) = Abel(imn)*Pmn(n-1,i,km2) + Bbel(imn)    &
                              & *Pmn(n-1,i,km0) - Cbel(imn)             &
                              & *Pmn(np1,i,km2)
            ENDDO
         ENDDO
 
      ELSEIF ( M==0 ) THEN
         DO np1 = ms , Nlat , ninc
            DO i = 1 , Late
               Pmn(np1,i,km0) = P0n(np1,i)
            ENDDO
         ENDDO
 
      ELSEIF ( M==1 ) THEN
         DO np1 = ms , Nlat , ninc
            DO i = 1 , Late
               Pmn(np1,i,km0) = P1n(np1,i)
            ENDDO
         ENDDO
      ENDIF
 
!     permute column indices
!     km0,km1,km2 store m,m-1,m-2 columns
      kmt = km0
      km0 = km2
      km2 = km1
      km1 = kmt
!     set current m index in output param km
      Km = kmt
      END SUBROUTINE DLEGIN1
 
 
      SUBROUTINE DZFIN(Isym,Nlat,Nlon,M,Z,I3,Wzfin)
      IMPLICIT NONE
      INTEGER I3 , imid , Isym , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION Wzfin , Z
      DIMENSION Z(1) , Wzfin(1)
      imid = (Nlat+1)/2
      lim = Nlat*imid
      mmax = MIN0(Nlat,Nlon/2+1)
      labc = ((mmax-2)*(Nlat+Nlat-mmax-1))/2
      iw1 = lim + 1
      iw2 = iw1 + lim
      iw3 = iw2 + labc
      iw4 = iw3 + labc
!
!     the length of wzfin is 2*lim+3*labc
!
      CALL DZFIN1(Isym,Nlat,M,Z,imid,I3,Wzfin,Wzfin(iw1),Wzfin(iw2),     &
               & Wzfin(iw3),Wzfin(iw4))
      END SUBROUTINE DZFIN


      SUBROUTINE DZFIN1(Isym,Nlat,M,Z,Imid,I3,Zz,Z1,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , Z , Z1 , Zz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Isym , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Z(Imid,Nlat,3) , Zz(Imid,1) , Z1(Imid,1) , A(1) , B(1) ,&
              & C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Z(i,np1,I3) = Zz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Z(i,np1,I3) = Z1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Isym/=1 ) THEN
            DO i = 1 , Imid
               Z(i,M+1,I3) = A(ns)*Z(i,M-1,i1) - C(ns)*Z(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Isym/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Z(i,M+2,I3) = A(ns)*Z(i,M,i1) - C(ns)*Z(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Isym==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Isym==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Z(i,np1,I3) = A(ns)*Z(i,np1-2,i1) + B(ns)             &
                              & *Z(i,np1-2,I3) - C(ns)*Z(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE DZFIN1


      SUBROUTINE DZFINIT(Nlat,Nlon,Wzfin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wzfin
      DIMENSION Wzfin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzfin is 3*((l-3)*l+2)/2 + 2*l*imid
!     the length of dwork is nlat+1
!
      CALL DZFINI1(Nlat,Nlon,imid,Wzfin,Wzfin(iw1),Dwork,Dwork(imid+1))
      END SUBROUTINE DZFINIT


      SUBROUTINE DZFINI1(Nlat,Nlon,Imid,Z,Abc,Cz,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Z
      INTEGER i , Imid , m , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations
!     where mmax = min0(nlat,nlon/2+1)
!     cz and work must each have nlat+1 locations
!
      DIMENSION Z(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , th , zh , Cz(*) , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      DO mp1 = 1 , 2
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDNZFK(Nlat,m,n,Cz,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDNZFT(Nlat,m,n,th,Cz,zh)
               Z(i,np1,mp1) = zh
            ENDDO
            Z(1,np1,mp1) = .5*Z(1,np1,mp1)
         ENDDO
      ENDDO
      CALL DRABCP(Nlat,Nlon,Abc)
      END SUBROUTINE DZFINI1


      SUBROUTINE DDNZFK(Nlat,M,N,Cz,Work)
      IMPLICIT NONE
      INTEGER i , idx , k , kdo , kp1 , lc , M , mmod , N , Nlat , nmod
!
!     dnzfk computes the coefficients in the trigonometric
!     expansion of the z functions that are used in spherical
!     harmonic analysis.
!
      DIMENSION Cz(1) , Work(1)
!
!     cz and work must both have nlat+1 locations
!
      DOUBLE PRECISION sum , sc1 , t1 , t2 , Work , Cz
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DDNLFK(M,N,Work)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod<=0 ) THEN
         IF ( mmod<=0 ) THEN
!
!     n even, m even
!
            kdo = N/2 + 1
            DO idx = 1 , lc
               i = idx + idx - 2
               sum = Work(1)/(1.D0-i*i)
               IF ( kdo>=2 ) THEN
                  DO 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)
                  ENDDO
               ENDIF
               Cz(idx) = sc1*sum
            ENDDO
            RETURN
         ELSE
!
!     n even, m odd
!
            kdo = N/2
            DO idx = 1 , lc
               i = idx + idx - 2
               sum = 0.
               DO 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)
               ENDDO
               Cz(idx) = sc1*sum
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod<=0 ) THEN
!
!     n odd, m even
!
         kdo = (N+1)/2
         DO idx = 1 , lc
            i = idx + idx - 1
            sum = 0.
            DO 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)
            ENDDO
            Cz(idx) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n odd, m odd
!
         kdo = (N+1)/2
         DO idx = 1 , lc
            i = idx + idx - 3
            sum = 0.
            DO 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)
            ENDDO
            Cz(idx) = sc1*sum
         ENDDO
      ENDIF
      END SUBROUTINE DDNZFK


      SUBROUTINE DDNZFT(Nlat,M,N,Th,Cz,Zh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
      DIMENSION Cz(1)
      DOUBLE PRECISION Cz , Zh , Th , cdt , sdt , cth , sth , chh
      Zh = 0.
      cdt = DCOS(Th+Th)
      sdt = DSIN(Th+Th)
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod<=0 ) THEN
         lc = Nlat/2
         lq = lc - 1
         IF ( nmod<=0 ) THEN
            IF ( mmod<=0 ) THEN
!
!     nlat even n even m even
!
               Zh = .5*Cz(1)
               cth = cdt
               sth = sdt
               DO k = 2 , lc
!     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
               ENDDO
               RETURN
            ELSE
!
!     nlat even n even m odd
!
               cth = cdt
               sth = sdt
               DO k = 1 , lq
!     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
               ENDDO
               RETURN
            ENDIF
!
!     nlat even n odd m even
!
         ELSEIF ( mmod<=0 ) THEN
            Zh = .5*Cz(lc)*DCOS((Nlat-1)*Th)
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            RETURN
         ELSE
!
!     nlat even n odd m odd
!
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         lc = (Nlat+1)/2
         lq = lc - 1
         ls = lc - 2
         IF ( nmod<=0 ) THEN
            IF ( mmod<=0 ) THEN
!
!     nlat odd n even m even
!
               Zh = .5*(Cz(1)+Cz(lc)*DCOS(2*lq*Th))
               cth = cdt
               sth = sdt
               DO k = 2 , lq
!     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
               ENDDO
               RETURN
            ELSE
!
!     nlat odd n even m odd
!
               cth = cdt
               sth = sdt
               DO k = 1 , ls
!     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
               ENDDO
               RETURN
            ENDIF
!
!     nlat odd n odd, m even
!
         ELSEIF ( mmod<=0 ) THEN
            cth = DCOS(Th)
            sth = DSIN(Th)
            DO k = 1 , lq
!     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
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     nlat odd n odd m odd
!
      cth = DCOS(Th)
      sth = DSIN(Th)
      DO k = 1 , lq
!     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
      ENDDO
      RETURN
99999 END SUBROUTINE DDNZFT


      SUBROUTINE DALIN(Isym,Nlat,Nlon,M,P,I3,Walin)
      IMPLICIT NONE
      INTEGER I3 , imid , Isym , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION P , Walin
      DIMENSION P(1) , Walin(1)
      imid = (Nlat+1)/2
      lim = Nlat*imid
      mmax = MIN0(Nlat,Nlon/2+1)
      labc = ((mmax-2)*(Nlat+Nlat-mmax-1))/2
      iw1 = lim + 1
      iw2 = iw1 + lim
      iw3 = iw2 + labc
      iw4 = iw3 + labc
!
!     the length of walin is ((5*l-7)*l+6)/2
!
      CALL DALIN1(Isym,Nlat,M,P,imid,I3,Walin,Walin(iw1),Walin(iw2),     &
               & Walin(iw3),Walin(iw4))
      END SUBROUTINE DALIN


      SUBROUTINE DALIN1(Isym,Nlat,M,P,Imid,I3,Pz,P1,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , P , P1 , Pz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Isym , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION P(Imid,Nlat,3) , Pz(Imid,1) , P1(Imid,1) , A(1) , B(1) ,&
              & C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               P(i,np1,I3) = Pz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               P(i,np1,I3) = P1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Isym/=1 ) THEN
            DO i = 1 , Imid
               P(i,M+1,I3) = A(ns)*P(i,M-1,i1) - C(ns)*P(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Isym/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               P(i,M+2,I3) = A(ns)*P(i,M,i1) - C(ns)*P(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Isym==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Isym==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  P(i,np1,I3) = A(ns)*P(i,np1-2,i1) + B(ns)             &
                              & *P(i,np1-2,I3) - C(ns)*P(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE DALIN1


      SUBROUTINE DALINIT(Nlat,Nlon,Walin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Walin
      DIMENSION Walin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of walin is 3*((l-3)*l+2)/2 + 2*l*imid
!     the length of work is nlat+1
!
      CALL DALINI1(Nlat,Nlon,imid,Walin,Walin(iw1),Dwork)
      END SUBROUTINE DALINIT


      SUBROUTINE DALINI1(Nlat,Nlon,Imid,P,Abc,Cp)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , P
      INTEGER i , Imid , m , mp1 , n , Nlat , Nlon , np1
      DIMENSION P(Imid,Nlat,2) , Abc(1) , Cp(1)
      DOUBLE PRECISION pi , dt , th , Cp , ph
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      DO mp1 = 1 , 2
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDNLFK(m,n,Cp)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDNLFT(m,n,th,Cp,ph)
               P(i,np1,mp1) = ph
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCP(Nlat,Nlon,Abc)
      END SUBROUTINE DALINI1

      
      SUBROUTINE DRABCP(Nlat,Nlon,Abc)
      IMPLICIT NONE
      DOUBLE PRECISION Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcp computes the coefficients in the recurrence
!     relation for the associated legendre fuctions. array abc
!     must have 3*((mmax-2)*(nlat+nlat-mmax-1))/2 locations.
!
      DIMENSION Abc(1)
      mmax = MIN0(Nlat,Nlon/2+1)
      labc = ((mmax-2)*(Nlat+Nlat-mmax-1))/2
      iw1 = labc + 1
      iw2 = iw1 + labc
      CALL DRABCP1(Nlat,Nlon,Abc,Abc(iw1),Abc(iw2))
      END SUBROUTINE DRABCP


      SUBROUTINE DRABCP1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!
!     coefficients a, b, and c for computing pbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 3 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         A(ns) = SQRT((tm+1.)*(tm-2.)/temp)
         C(ns) = SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            A(ns) = SQRT((tm+3.)*(tm-2.)/temp)
            C(ns) = SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  A(ns) = SQRT(cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE DRABCP1

      
      SUBROUTINE DSEA1(Nlat,Nlon,Imid,Z,Idz,Zin,Wzfin,Dwork)
      IMPLICIT NONE
      INTEGER i , i3 , Idz , Imid , m , mmax , mn , mp1 , Nlat , Nlon , &
            & np1
      DOUBLE PRECISION Wzfin , Z , Zin
      DIMENSION Z(Idz,*) , Zin(Imid,Nlat,3) , Wzfin(*)
      DOUBLE PRECISION Dwork(*)
      CALL DZFINIT(Nlat,Nlon,Wzfin,Dwork)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 1 , mmax
         m = mp1 - 1
         CALL DZFIN(0,Nlat,Nlon,m,Zin,i3,Wzfin)
         DO np1 = mp1 , Nlat
            mn = m*(Nlat-1) - (m*(m-1))/2 + np1
            DO i = 1 , Imid
               Z(mn,i) = Zin(i,np1,i3)
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DSEA1


      SUBROUTINE DSES1(Nlat,Nlon,Imid,P,Pin,Walin,Dwork)
      IMPLICIT NONE
      INTEGER i , i3 , Imid , m , mmax , mn , mp1 , Nlat , Nlon , np1
      DOUBLE PRECISION P , Pin , Walin
      DIMENSION P(Imid,*) , Pin(Imid,Nlat,3) , Walin(*)
      DOUBLE PRECISION Dwork(*)
      CALL DALINIT(Nlat,Nlon,Walin,Dwork)
      mmax = MIN0(Nlat,Nlon/2+1)
      DO mp1 = 1 , mmax
         m = mp1 - 1
         CALL DALIN(0,Nlat,Nlon,m,Pin,i3,Walin)
         DO np1 = mp1 , Nlat
            mn = m*(Nlat-1) - (m*(m-1))/2 + np1
            DO i = 1 , Imid
               P(i,mn) = Pin(i,np1,i3)
            ENDDO
         ENDDO
      ENDDO
    END SUBROUTINE DSES1


      SUBROUTINE DZVINIT(Nlat,Nlon,Wzvin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wzvin
      DIMENSION Wzvin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzvin is
!         2*nlat*imid +3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     the length of dwork is 2*nlat+2
!
      CALL DZVINI1(Nlat,Nlon,imid,Wzvin,Wzvin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE DZVINIT


      SUBROUTINE DZVINI1(Nlat,Nlon,Imid,Zv,Abc,Czv,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Zv
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     czv and work must each have nlat+1  locations
!
      DIMENSION Zv(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Czv(1) , zvh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDZVK(Nlat,m,n,Czv,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDZVT(Nlat,m,n,th,Czv,zvh)
               Zv(i,np1,mp1) = zvh
            ENDDO
            Zv(1,np1,mp1) = .5*Zv(1,np1,mp1)
         ENDDO
      ENDDO
      CALL DRABCV(Nlat,Nlon,Abc)
      END SUBROUTINE DZVINI1


      SUBROUTINE DZWINIT(Nlat,Nlon,Wzwin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wzwin
      DIMENSION Wzwin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wzvin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL DZWINI1(Nlat,Nlon,imid,Wzwin,Wzwin(iw1),Dwork,Dwork(Nlat+2))
    END SUBROUTINE DZWINIT
    

      SUBROUTINE DZWINI1(Nlat,Nlon,Imid,Zw,Abc,Czw,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Zw
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     czw and work must each have nlat+1 locations
!
      DIMENSION Zw(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Czw(1) , zwh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDZWK(Nlat,m,n,Czw,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDZWT(Nlat,m,n,th,Czw,zwh)
               Zw(i,np1,m) = zwh
            ENDDO
            Zw(1,np1,m) = .5*Zw(1,np1,m)
         ENDDO
      ENDDO
      CALL DRABCW(Nlat,Nlon,Abc)
      END SUBROUTINE DZWINI1


      SUBROUTINE DZVIN(Ityp,Nlat,Nlon,M,Zv,I3,Wzvin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION Wzvin , Zv
      DIMENSION Zv(1) , Wzvin(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
!
!     the length of wzvin is 2*lim+3*labc
!
      CALL DZVIN1(Ityp,Nlat,M,Zv,imid,I3,Wzvin,Wzvin(iw1),Wzvin(iw2),    &
               & Wzvin(iw3),Wzvin(iw4))
      END SUBROUTINE DZVIN


      SUBROUTINE DZVIN1(Ityp,Nlat,M,Zv,Imid,I3,Zvz,Zv1,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , Zv , Zv1 , Zvz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Zv(Imid,Nlat,3) , Zvz(Imid,1) , Zv1(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Zv(i,np1,I3) = Zvz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Zv(i,np1,I3) = Zv1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Zv(i,M+1,I3) = A(ns)*Zv(i,M-1,i1) - C(ns)*Zv(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Zv(i,M+2,I3) = A(ns)*Zv(i,M,i1) - C(ns)*Zv(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Zv(i,np1,I3) = A(ns)*Zv(i,np1-2,i1) + B(ns)           &
                               & *Zv(i,np1-2,I3) - C(ns)*Zv(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE DZVIN1


      SUBROUTINE DZWIN(Ityp,Nlat,Nlon,M,Zw,I3,Wzwin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION Wzwin , Zw
      DIMENSION Zw(1) , Wzwin(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
!
!     the length of wzwin is 2*lim+3*labc
!
      CALL DZWIN1(Ityp,Nlat,M,Zw,imid,I3,Wzwin,Wzwin(iw1),Wzwin(iw2),    &
               & Wzwin(iw3),Wzwin(iw4))
      END SUBROUTINE DZWIN


      SUBROUTINE DZWIN1(Ityp,Nlat,M,Zw,Imid,I3,Zw1,Zw2,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , Zw , Zw1 , Zw2
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Zw(Imid,Nlat,3) , Zw1(Imid,1) , Zw2(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<2 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Zw(i,np1,I3) = Zw1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==2 ) THEN
         DO np1 = 3 , Nlat
            DO i = 1 , Imid
               Zw(i,np1,I3) = Zw2(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Zw(i,M+1,I3) = A(ns)*Zw(i,M-1,i1) - C(ns)*Zw(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Zw(i,M+2,I3) = A(ns)*Zw(i,M,i1) - C(ns)*Zw(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Zw(i,np1,I3) = A(ns)*Zw(i,np1-2,i1) + B(ns)           &
                               & *Zw(i,np1-2,I3) - C(ns)*Zw(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END  SUBROUTINE DZWIN1


      SUBROUTINE DVBINIT(Nlat,Nlon,Wvbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wvbin
      DIMENSION Wvbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL DVBINI1(Nlat,Nlon,imid,Wvbin,Wvbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE DVBINIT


      SUBROUTINE DVBINI1(Nlat,Nlon,Imid,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cvb(1) , th , vbh , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDVBK(m,n,Cvb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDVBT(m,n,th,Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCV(Nlat,Nlon,Abc)
      END SUBROUTINE DVBINI1


      SUBROUTINE DWBINIT(Nlat,Nlon,Wwbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL DWBINI1(Nlat,Nlon,imid,Wwbin,Wwbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE DWBINIT

      
      SUBROUTINE DWBINI1(Nlat,Nlon,Imid,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cwb(1) , wbh , th , Work(1)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDWBK(m,n,Cwb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDWBT(m,n,th,Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCW(Nlat,Nlon,Abc)
      END SUBROUTINE DWBINI1


      SUBROUTINE DVBIN(Ityp,Nlat,Nlon,M,Vb,I3,Wvbin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION Vb , Wvbin
      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
!
!     the length of wvbin is 2*lim+3*labc
!
      CALL DVBIN1(Ityp,Nlat,M,Vb,imid,I3,Wvbin,Wvbin(iw1),Wvbin(iw2),    &
               & Wvbin(iw3),Wvbin(iw4))
      END SUBROUTINE DVBIN


      SUBROUTINE DVBIN1(Ityp,Nlat,M,Vb,Imid,I3,Vbz,Vb1,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , Vb , Vb1 , Vbz
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Vb(Imid,Nlat,3) , Vbz(Imid,1) , Vb1(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<1 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 1 , Nlat
            DO i = 1 , Imid
               Vb(i,np1,I3) = Vbz(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==1 ) THEN
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Vb(i,np1,I3) = Vb1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Vb(i,M+1,I3) = A(ns)*Vb(i,M-1,i1) - C(ns)*Vb(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Vb(i,M+2,I3) = A(ns)*Vb(i,M,i1) - C(ns)*Vb(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Vb(i,np1,I3) = A(ns)*Vb(i,np1-2,i1) + B(ns)           &
                               & *Vb(i,np1-2,I3) - C(ns)*Vb(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE DVBIN1


      SUBROUTINE DWBIN(Ityp,Nlat,Nlon,M,Wb,I3,Wwbin)
      IMPLICIT NONE
      INTEGER I3 , imid , Ityp , iw1 , iw2 , iw3 , iw4 , labc , lim ,   &
            & M , mmax , Nlat , Nlon
      DOUBLE PRECISION Wb , Wwbin
      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
!
!     the length of wwbin is 2*lim+3*labc
!
      CALL DWBIN1(Ityp,Nlat,M,Wb,imid,I3,Wwbin,Wwbin(iw1),Wwbin(iw2),    &
               & Wwbin(iw3),Wwbin(iw4))
      END SUBROUTINE DWBIN

      
      SUBROUTINE DWBIN1(Ityp,Nlat,M,Wb,Imid,I3,Wb1,Wb2,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , Wb , Wb1 , Wb2
      INTEGER i , i1 , i2 , I3 , ihold , Imid , Ityp , M , Nlat , np1 , &
            & ns , nstp , nstrt
      DIMENSION Wb(Imid,Nlat,3) , Wb1(Imid,1) , Wb2(Imid,1) , A(1) ,    &
              & B(1) , C(1)
      SAVE i1 , i2
      ihold = i1
      i1 = i2
      i2 = I3
      I3 = ihold
      IF ( M<2 ) THEN
         i1 = 1
         i2 = 2
         I3 = 3
         DO np1 = 2 , Nlat
            DO i = 1 , Imid
               Wb(i,np1,I3) = Wb1(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSEIF ( M==2 ) THEN
         DO np1 = 3 , Nlat
            DO i = 1 , Imid
               Wb(i,np1,I3) = Wb2(i,np1)
            ENDDO
         ENDDO
         RETURN
      ELSE
         ns = ((M-2)*(Nlat+Nlat-M-1))/2 + 1
         IF ( Ityp/=1 ) THEN
            DO i = 1 , Imid
               Wb(i,M+1,I3) = A(ns)*Wb(i,M-1,i1) - C(ns)*Wb(i,M+1,i1)
            ENDDO
         ENDIF
         IF ( M==Nlat-1 ) RETURN
         IF ( Ityp/=2 ) THEN
            ns = ns + 1
            DO i = 1 , Imid
               Wb(i,M+2,I3) = A(ns)*Wb(i,M,i1) - C(ns)*Wb(i,M+2,i1)
            ENDDO
         ENDIF
         nstrt = M + 3
         IF ( Ityp==1 ) nstrt = M + 4
         IF ( nstrt<=Nlat ) THEN
            nstp = 2
            IF ( Ityp==0 ) nstp = 1
            DO np1 = nstrt , Nlat , nstp
               ns = ns + nstp
               DO i = 1 , Imid
                  Wb(i,np1,I3) = A(ns)*Wb(i,np1-2,i1) + B(ns)           &
                               & *Wb(i,np1-2,I3) - C(ns)*Wb(i,np1,i1)
               ENDDO
            ENDDO
         ENDIF
      ENDIF
      END SUBROUTINE DWBIN1


      SUBROUTINE DDZVK(Nlat,M,N,Czv,Work)
      IMPLICIT NONE
      INTEGER i , id , k , kdo , lc , M , mmod , N , Nlat , nmod
!
!     subroutine dzvk computes the coefficients in the trigonometric
!     expansion of the quadrature function zvbar(n,m,theta)
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of wbarv(n,m,theta)
!
!     m      the order (superscript) of wbarv(n,m,theta)
!
!     work   a work array with at least (nlat+1)/2 locations
!
!     output parameter
!
!     czv     the fourier coefficients of zvbar(n,m,theta).
!
      DIMENSION Czv(1) , Work(1)
      DOUBLE PRECISION Czv , sc1 , sum , Work , t1 , t2
      IF ( N<=0 ) RETURN
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DDVBK(M,N,Work,Czv)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     n odd, m odd
!
            kdo = (N+1)/2
            DO id = 1 , lc
               i = id + id - 1
               sum = 0.
               DO 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)
               ENDDO
               Czv(id) = sc1*sum
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even, m odd
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 2
            sum = 0.
            DO 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)
            ENDDO
            Czv(id) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n even, m even
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 2
            sum = 0.
            DO 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)
            ENDDO
            Czv(id) = sc1*sum
         ENDDO
         RETURN
      ENDIF
!
!     n odd, m even
!
      kdo = (N+1)/2
      DO id = 1 , lc
         i = id + id - 3
         sum = 0.
         DO 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)
         ENDDO
         Czv(id) = sc1*sum
      ENDDO
      RETURN
99999 END SUBROUTINE DDZVK


      SUBROUTINE DDZVT(Nlat,M,N,Th,Czv,Zvh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
!
!     subroutine dzvt tabulates the function zvbar(n,m,theta)
!     at theta = th in double precision
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of zvbar(n,m,theta)
!
!     m      the order (superscript) of zvbar(n,m,theta)
!
!     czv     the fourier coefficients of zvbar(n,m,theta)
!             as computed by subroutine zwk.
!
!     output parameter
!
!     zvh     zvbar(m,n,theta) evaluated at theta = th
!
      DIMENSION Czv(1)
      DOUBLE PRECISION Th , Czv , Zvh , cth , sth , cdt , sdt , chh
      Zvh = 0.
      IF ( N<=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.*sth*cth
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod==0 ) THEN
         IF ( nmod==0 ) THEN
            cth = cdt
            sth = sdt
            IF ( mmod/=0 ) THEN
!
!     nlat even  n even  m odd
!
               Zvh = .5*Czv(1)
               DO k = 2 , lc
                  Zvh = Zvh + Czv(k)*cth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               RETURN
            ELSE
!
!     nlat even  n even  m even
!
               DO k = 1 , lq
                  Zvh = Zvh + Czv(k+1)*sth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               RETURN
            ENDIF
         ELSEIF ( mmod/=0 ) THEN
!
!     nlat even  n odd  m odd
!
            Zvh = .5*Czv(lc)*DCOS((Nlat-1)*Th)
            DO k = 1 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n odd  m odd
!
            DO k = 1 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     nlat odd  n odd  m even
!
            DO k = 1 , lq
               Zvh = Zvh + Czv(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSE
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n even  m odd
!
            Zvh = .5*Czv(1)
            DO k = 2 , lq
               Zvh = Zvh + Czv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            Zvh = Zvh + .5*Czv(lc)*DCOS((Nlat-1)*Th)
            RETURN
         ELSE
!
!     nlat odd  n even  m even
!
            DO k = 1 , ls
               Zvh = Zvh + Czv(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     nlat even  n odd  m even
!
      DO k = 1 , lq
         Zvh = Zvh + Czv(k+1)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDZVT

      
      SUBROUTINE DDZWK(Nlat,M,N,Czw,Work)
      IMPLICIT NONE
      INTEGER i , id , k , kdo , kp1 , lc , M , mmod , N , Nlat , nmod
!
!     subroutine dzwk computes the coefficients in the trigonometric
!     expansion of the quadrature function zwbar(n,m,theta)
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!
!     n      the degree (subscript) of zwbar(n,m,theta)
!
!     m      the order (superscript) of zwbar(n,m,theta)
!
!     work   a work array with at least (nlat+1)/2 locations
!
!     output parameter
!
!     czw     the fourier coefficients of zwbar(n,m,theta).
!
      DIMENSION Czw(1) , Work(1)
      DOUBLE PRECISION Czw , Work , sc1 , sum , t1 , t2
      IF ( N<=0 ) RETURN
      lc = (Nlat+1)/2
      sc1 = 2.D0/FLOAT(Nlat-1)
      CALL DDWBK(M,N,Work,Czw)
      nmod = MOD(N,2)
      mmod = MOD(M,2)
      IF ( nmod/=0 ) THEN
         IF ( mmod/=0 ) THEN
!
!     n odd, m odd
!
            kdo = (N+1)/2
            DO id = 1 , lc
               i = id + id - 2
               sum = Work(1)/(1.D0-i*i)
               IF ( kdo>=2 ) THEN
                  DO 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)
                  ENDDO
               ENDIF
               Czw(id) = sc1*sum
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even, m odd
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 1
            sum = 0.
            DO 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)
            ENDDO
            Czw(id) = sc1*sum
         ENDDO
         RETURN
      ELSE
!
!     n even, m even
!
         kdo = N/2
         DO id = 1 , lc
            i = id + id - 3
            sum = 0.
            DO 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)
            ENDDO
            Czw(id) = sc1*sum
         ENDDO
         RETURN
      ENDIF
!
!     n odd, m even
!
      kdo = (N-1)/2
      DO id = 1 , lc
         i = id + id - 2
         sum = 0.
         DO 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)
         ENDDO
         Czw(id) = sc1*sum
      ENDDO
      RETURN
99999 END SUBROUTINE DDZWK


      SUBROUTINE DDZWT(Nlat,M,N,Th,Czw,Zwh)
      IMPLICIT NONE
      INTEGER k , lc , lmod , lq , ls , M , mmod , N , Nlat , nmod
!
!     subroutine dzwt tabulates the function zwbar(n,m,theta)
!     at theta = th in double precision
!
!     input parameters
!
!     nlat      the number of colatitudes including the poles.
!            nlat must be an odd integer
!
!     n      the degree (subscript) of zwbar(n,m,theta)
!
!     m      the order (superscript) of zwbar(n,m,theta)
!
!     czw     the fourier coefficients of zwbar(n,m,theta)
!             as computed by subroutine zwk.
!
!     output parameter
!
!     zwh     zwbar(m,n,theta) evaluated at theta = th
!
      DIMENSION Czw(1)
      DOUBLE PRECISION Czw , Zwh , Th , cth , sth , cdt , sdt , chh
      Zwh = 0.
      IF ( N<=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.*sth*cth
      lmod = MOD(Nlat,2)
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( lmod==0 ) THEN
         IF ( nmod/=0 ) THEN
            cth = cdt
            sth = sdt
            IF ( mmod/=0 ) THEN
!
!     nlat even  n odd  m odd
!
               Zwh = .5*Czw(1)
               DO k = 2 , lc
                  Zwh = Zwh + Czw(k)*cth
                  chh = cdt*cth - sdt*sth
                  sth = sdt*cth + cdt*sth
                  cth = chh
               ENDDO
               GOTO 99999
            ENDIF
         ELSEIF ( mmod/=0 ) THEN
!
!     nlat even  n even  m odd
!
            Zwh = .5*Czw(lc)*DCOS((Nlat-1)*Th)
            DO k = 1 , lq
               Zwh = Zwh + Czw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     nlat even  n even  m even
!
            DO k = 1 , lq
               Zwh = Zwh + Czw(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     nlat odd  n odd  m odd
!
            Zwh = .5*Czw(1)
            DO k = 2 , lq
               Zwh = Zwh + Czw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            Zwh = Zwh + .5*Czw(lc)*DCOS((Nlat-1)*Th)
            RETURN
         ELSE
!
!     nlat odd  n odd  m even
!
            DO k = 1 , ls
               Zwh = Zwh + Czw(k+1)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     nlat odd  n even  m odd
!
         DO k = 1 , lq
            Zwh = Zwh + Czw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     nlat odd  n even  m even
!
         DO k = 1 , lq
            Zwh = Zwh + Czw(k+1)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     nlat even  n odd  m even
!
      DO k = 1 , lq
         Zwh = Zwh + Czw(k+1)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDZWT


      SUBROUTINE DDVBK(M,N,Cv,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N , ncv
      DOUBLE PRECISION srnp1
      DOUBLE PRECISION Cv(1) , Work(1) , fn , fk , cf
      Cv(1) = 0.
      IF ( N<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DNLFK(M,N,Work)
      IF ( modn/=0 ) THEN
         ncv = (N+1)/2
         fk = -1.
         IF ( modm/=0 ) THEN
!
!     n odd m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = fk*Work(l)/srnp1
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         ncv = N/2
         IF ( ncv==0 ) RETURN
         fk = 0.
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = fk*Work(l)/srnp1
            ENDDO
            RETURN
         ELSE
!
!     n even m even
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*Work(l+1)/srnp1
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     n odd m even
!
      DO l = 1 , ncv
         fk = fk + 2.
         Cv(l) = -fk*Work(l)/srnp1
      ENDDO
      RETURN
99999 END SUBROUTINE DDVBK


      SUBROUTINE DDWBK(M,N,Cw,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N
      DOUBLE PRECISION Cw(1) , Work(1) , fn , cf , srnp1
      Cw(1) = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DDNLFK(M,N,Work)
      IF ( M/=0 ) THEN
         IF ( modn==0 ) THEN
            l = N/2
            IF ( l/=0 ) THEN
               IF ( modm/=0 ) THEN
!
!     n even m odd
!
                  Cw(l) = cf*Work(l)
 5                l = l - 1
                  IF ( l>0 ) THEN
                     Cw(l) = Cw(l+1) + cf*Work(l)
                     GOTO 5
                  ENDIF
               ELSE
!
!     n even m even
!
                  Cw(l) = -cf*Work(l+1)
 10               l = l - 1
                  IF ( l>0 ) THEN
                     Cw(l) = Cw(l+1) - cf*Work(l+1)
                     GOTO 10
                  ENDIF
               ENDIF
            ENDIF
         ELSEIF ( modm/=0 ) THEN
!
!     n odd m odd
!
            l = (N+1)/2
            Cw(l) = cf*Work(l)
 20         l = l - 1
            IF ( l>0 ) THEN
               Cw(l) = Cw(l+1) + cf*Work(l)
               GOTO 20
            ENDIF
         ELSE
            l = (N-1)/2
            IF ( l/=0 ) THEN
!
!     n odd m even
!
               Cw(l) = -cf*Work(l+1)
 30            l = l - 1
               IF ( l>0 ) THEN
                  Cw(l) = Cw(l+1) - cf*Work(l+1)
                  GOTO 30
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      END SUBROUTINE DDWBK


      SUBROUTINE DDVBT(M,N,Theta,Cv,Vh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncv , nmod
      DIMENSION Cv(1)
      DOUBLE PRECISION Cv , Vh , Theta , cth , sth , cdt , sdt , chh
      Vh = 0.
      IF ( N==0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod==0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     n even  m odd
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     n even  m even
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
         ncv = (N+1)/2
         DO k = 1 , ncv
            Vh = Vh + Cv(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         GOTO 99999
      ENDIF
!
!     n odd m even
!
      ncv = (N+1)/2
      DO k = 1 , ncv
         Vh = Vh + Cv(k)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDVBT


      SUBROUTINE DDWBT(M,N,Theta,Cw,Wh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncw , nmod
      DIMENSION Cw(1)
      DOUBLE PRECISION Theta , Cw , Wh , cth , sth , cdt , sdt , chh
      Wh = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
            ncw = (N+1)/2
            Wh = .5*Cw(1)
            IF ( ncw<2 ) RETURN
            DO k = 2 , ncw
               Wh = Wh + Cw(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even  m odd
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     n even  m even
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     n odd m even
!
      ncw = (N-1)/2
      DO k = 1 , ncw
         Wh = Wh + Cw(k)*sth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDWBT


      SUBROUTINE DRABCV(Nlat,Nlon,Abc)
      IMPLICIT NONE
      DOUBLE PRECISION Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcp computes the coefficients in the recurrence
!     relation for the functions vbar(m,n,theta). array abc
!     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
!
      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 DRABCV1(Nlat,Nlon,Abc,Abc(iw1),Abc(iw2))
      END SUBROUTINE DRABCV

      
      SUBROUTINE DRABCV1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn , tpn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!
!     coefficients a, b, and c for computing vbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( mmax<3 ) RETURN
      DO mp1 = 3 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.))
         A(ns) = SQRT(tpn*(tm+1.)*(tm-2.)/temp)
         C(ns) = SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            tpn = (fm-1.)*fm/((fm+1.)*(fm+2.))
            A(ns) = SQRT(tpn*(tm+3.)*(tm-2.)/temp)
            C(ns) = SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.))
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  A(ns) = SQRT(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(tpn*cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE DRABCV1


      SUBROUTINE DRABCW(Nlat,Nlon,Abc)
      IMPLICIT NONE
      DOUBLE PRECISION Abc
      INTEGER iw1 , iw2 , labc , mmax , Nlat , Nlon
!
!     subroutine rabcw computes the coefficients in the recurrence
!     relation for the functions wbar(m,n,theta). array abc
!     must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2 locations.
!
      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 DRABCW1(Nlat,Nlon,Abc,Abc(iw1),Abc(iw2))
      END SUBROUTINE DRABCW


      SUBROUTINE DRABCW1(Nlat,Nlon,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , C , cn , fm , fn , fnmm , fnpm , temp , tm , tn ,    &
         & tph , tpn
      INTEGER m , mmax , mp1 , mp3 , n , Nlat , Nlon , np1 , ns
!*** End of declarations inserted by SPAG
!
!     coefficients a, b, and c for computing wbar(m,n,theta) are
!     stored in location ((m-2)*(nlat+nlat-m-1))/2+n+1
!
      DIMENSION A(1) , B(1) , C(1)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( mmax<4 ) RETURN
      DO mp1 = 4 , mmax
         m = mp1 - 1
         ns = ((m-2)*(Nlat+Nlat-m-1))/2 + 1
         fm = FLOAT(m)
         tm = fm + fm
         temp = tm*(tm-1.)
         tpn = (fm-2.)*(fm-1.)/(fm*(fm+1.))
         tph = fm/(fm-2.)
         A(ns) = tph*SQRT(tpn*(tm+1.)*(tm-2.)/temp)
         C(ns) = tph*SQRT(2./temp)
         IF ( m/=Nlat-1 ) THEN
            ns = ns + 1
            temp = tm*(tm+1.)
            tpn = (fm-1.)*fm/((fm+1.)*(fm+2.))
            tph = fm/(fm-2.)
            A(ns) = tph*SQRT(tpn*(tm+3.)*(tm-2.)/temp)
            C(ns) = tph*SQRT(6./temp)
            mp3 = m + 3
            IF ( mp3<=Nlat ) THEN
               DO np1 = mp3 , Nlat
                  n = np1 - 1
                  ns = ns + 1
                  fn = FLOAT(n)
                  tn = fn + fn
                  cn = (tn+1.)/(tn-3.)
                  fnpm = fn + fm
                  fnmm = fn - fm
                  temp = fnpm*(fnpm-1.)
                  tpn = (fn-2.)*(fn-1.)/(fn*(fn+1.))
                  tph = fm/(fm-2.)
                  A(ns) = tph*SQRT(tpn*cn*(fnpm-3.)*(fnpm-2.)/temp)
                  B(ns) = SQRT(tpn*cn*fnmm*(fnmm-1.)/temp)
                  C(ns) = tph*SQRT((fnmm+1.)*(fnmm+2.)/temp)
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      END SUBROUTINE  DRABCW1

      
      SUBROUTINE DVTINIT(Nlat,Nlon,Wvbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wvbin
      DIMENSION Wvbin(*)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL DVTINI1(Nlat,Nlon,imid,Wvbin,Wvbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE DVTINIT


      SUBROUTINE DVTINI1(Nlat,Nlon,Imid,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1) , Cvb(1)
      DOUBLE PRECISION pi , dt , Cvb , th , vbh , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDVTK(m,n,Cvb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DDVTT(m,n,th,Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCV(Nlat,Nlon,Abc)
      END SUBROUTINE DVTINI1


      SUBROUTINE DWTINIT(Nlat,Nlon,Wwbin,Dwork)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Dwork(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of dwork is 2*nlat+2
!
      CALL DWTINI1(Nlat,Nlon,imid,Wwbin,Wwbin(iw1),Dwork,Dwork(Nlat+2))
      END SUBROUTINE DWTINIT


      SUBROUTINE DWTINI1(Nlat,Nlon,Imid,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION pi , dt , Cwb(*) , wbh , th , Work(*)
      pi = 4.*DATAN(1.D0)
      dt = pi/(Nlat-1)
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDWTK(m,n,Cwb,Work)
            DO i = 1 , Imid
               th = (i-1)*dt
               CALL DWTT(m,n,th,Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCW(Nlat,Nlon,Abc)
      END SUBROUTINE DWTINI1


      SUBROUTINE DVTGINT(Nlat,Nlon,Theta,Wvbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wvbin
      DIMENSION Wvbin(*)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL DVTGIT1(Nlat,Nlon,imid,Theta,Wvbin,Wvbin(iw1),Work,           &
                & Work(Nlat+2))
!    1                        work,work(2*nlat+3))
      END SUBROUTINE DVTGINT


      SUBROUTINE DVTGIT1(Nlat,Nlon,Imid,Theta,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1   locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(*)
      DOUBLE PRECISION Theta(*) , Cvb(*) , Work(*) , vbh
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDVTK(m,n,Cvb,Work)
            DO i = 1 , Imid
               CALL DDVTT(m,n,Theta(i),Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCV(Nlat,Nlon,Abc)
    END SUBROUTINE DVTGIT1


      SUBROUTINE DWTGINT(Nlat,Nlon,Theta,Wwbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wwbin
      DIMENSION Wwbin(*)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL DWTGIT1(Nlat,Nlon,imid,Theta,Wwbin,Wwbin(iw1),Work,           &
                & Work(Nlat+2))
      END SUBROUTINE DWTGINT


      SUBROUTINE DWTGIT1(Nlat,Nlon,Imid,Theta,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((nlat-3)*nlat+2)/2 locations
!     cwb and work must each have nlat+1 locations
!
      DIMENSION Wb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION Theta(*) , Cwb(*) , Work(*) , wbh
      mdo = MIN0(3,Nlat,(Nlon+1)/2)
      IF ( mdo<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDWTK(m,n,Cwb,Work)
            DO i = 1 , Imid
               CALL DDWTT(m,n,Theta(i),Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCW(Nlat,Nlon,Abc)
      END SUBROUTINE DWTGIT1


      SUBROUTINE DDVTK(M,N,Cv,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N , ncv
      DOUBLE PRECISION Cv(*) , Work(*) , fn , fk , cf , srnp1
      Cv(1) = 0.
      IF ( N<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DDNLFK(M,N,Work)
      IF ( modn/=0 ) THEN
         ncv = (N+1)/2
         fk = -1.
         IF ( modm/=0 ) THEN
!
!     n odd m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l)/srnp1
            ENDDO
            GOTO 99999
         ENDIF
      ELSE
         ncv = N/2
         IF ( ncv==0 ) RETURN
         fk = 0.
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l)/srnp1
            ENDDO
            RETURN
         ELSE
!
!     n even m even
!
            DO l = 1 , ncv
               fk = fk + 2.
               Cv(l) = -fk*fk*Work(l+1)/srnp1
            ENDDO
            RETURN
         ENDIF
      ENDIF
!
!     n odd m even
!
      DO l = 1 , ncv
         fk = fk + 2.
         Cv(l) = -fk*fk*Work(l)/srnp1
      ENDDO
      RETURN
99999 END SUBROUTINE DDVTK


      SUBROUTINE DDWTK(M,N,Cw,Work)
      IMPLICIT NONE
      INTEGER l , M , modm , modn , N
      DOUBLE PRECISION Cw(*) , Work(*) , fn , cf , srnp1
      Cw(1) = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      fn = N
      srnp1 = DSQRT(fn*(fn+1.))
      cf = 2.*M/srnp1
      modn = MOD(N,2)
      modm = MOD(M,2)
      CALL DDNLFK(M,N,Work)
      IF ( M==0 ) GOTO 99999
      IF ( modn==0 ) THEN
         l = N/2
         IF ( l==0 ) GOTO 99999
         IF ( modm/=0 ) THEN
!
!     n even m odd
!
            Cw(l) = cf*Work(l)
         ELSE
!
!     n even m even
!
            Cw(l) = -cf*Work(l+1)
 20         l = l - 1
            IF ( l<=0 ) GOTO 99999
            Cw(l) = Cw(l+1) - cf*Work(l+1)
            Cw(l+1) = (l+l+1)*Cw(l+1)
            GOTO 20
         ENDIF
      ELSEIF ( modm/=0 ) THEN
!
!     n odd m odd
!
         l = (N+1)/2
         Cw(l) = cf*Work(l)
         GOTO 300
      ELSE
         l = (N-1)/2
         IF ( l==0 ) GOTO 99999
!
!     n odd m even
!
         Cw(l) = -cf*Work(l+1)
         GOTO 200
      ENDIF
 100  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) + cf*Work(l)
      Cw(l+1) = -(l+l+1)*Cw(l+1)
      GOTO 100
 200  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) - cf*Work(l+1)
      Cw(l+1) = (l+l+2)*Cw(l+1)
      GOTO 200
 300  l = l - 1
      IF ( l<0 ) GOTO 99999
      IF ( l/=0 ) Cw(l) = Cw(l+1) + cf*Work(l)
      Cw(l+1) = -(l+l)*Cw(l+1)
      GOTO 300
99999 END SUBROUTINE DDWTK 


      SUBROUTINE DDVTT(M,N,Theta,Cv,Vh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncv , nmod
      DIMENSION Cv(1)
      DOUBLE PRECISION Cv , Vh , Theta , cth , sth , cdt , sdt , chh
      Vh = 0.
      IF ( N==0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod==0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
!     n even  m odd
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ELSE
!
!     n even  m even
!
            ncv = N/2
            DO k = 1 , ncv
               Vh = Vh + Cv(k)*cth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            RETURN
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
         ncv = (N+1)/2
         DO k = 1 , ncv
            Vh = Vh + Cv(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         GOTO 99999
      ENDIF
!
!     n odd m even
!
      ncv = (N+1)/2
      DO k = 1 , ncv
         Vh = Vh + Cv(k)*cth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDVTT


      SUBROUTINE DDWTT(M,N,Theta,Cw,Wh)
      IMPLICIT NONE
      INTEGER k , M , mmod , N , ncw , nmod
      DIMENSION Cw(1)
      DOUBLE PRECISION Theta , Cw , Wh , cth , sth , cdt , sdt , chh
      Wh = 0.
      IF ( N<=0 .OR. M<=0 ) RETURN
      cth = DCOS(Theta)
      sth = DSIN(Theta)
      cdt = cth*cth - sth*sth
      sdt = 2.*sth*cth
      mmod = MOD(M,2)
      nmod = MOD(N,2)
      IF ( nmod/=0 ) THEN
         cth = cdt
         sth = sdt
         IF ( mmod/=0 ) THEN
!
! case m odd and n odd
!
            ncw = (N+1)/2
            Wh = 0.
            IF ( ncw<2 ) RETURN
            DO k = 2 , ncw
               Wh = Wh + Cw(k)*sth
               chh = cdt*cth - sdt*sth
               sth = sdt*cth + cdt*sth
               cth = chh
            ENDDO
            GOTO 99999
         ENDIF
      ELSEIF ( mmod/=0 ) THEN
!
!     n even  m odd
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*sth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ELSE
!
!     n even  m even
!
         ncw = N/2
         DO k = 1 , ncw
            Wh = Wh + Cw(k)*cth
            chh = cdt*cth - sdt*sth
            sth = sdt*cth + cdt*sth
            cth = chh
         ENDDO
         RETURN
      ENDIF
!
!     n odd m even
!
      ncw = (N-1)/2
      DO k = 1 , ncw
         Wh = Wh + Cw(k)*cth
         chh = cdt*cth - sdt*sth
         sth = sdt*cth + cdt*sth
         cth = chh
      ENDDO
      RETURN
99999 END SUBROUTINE DDWTT


      SUBROUTINE DVBGINT(Nlat,Nlon,Theta,Wvbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wvbin
      DIMENSION Wvbin(1)
      DOUBLE PRECISION Theta(*) , Work(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wvbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL DVBGIT1(Nlat,Nlon,imid,Theta,Wvbin,Wvbin(iw1),Work,           &
                & Work(Nlat+2))
!    1                        work,work(2*nlat+3))
      END SUBROUTINE DVBGINT


      SUBROUTINE DVBGIT1(Nlat,Nlon,Imid,Theta,Vb,Abc,Cvb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Vb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
!     locations where mmax = min0(nlat,(nlon+1)/2)
!     cvb and work must each have nlat+1 locations
!
      DIMENSION Vb(Imid,Nlat,2) , Abc(1)
      DOUBLE PRECISION Cvb(1) , Theta(1) , vbh , Work(1)
      mdo = MIN0(2,Nlat,(Nlon+1)/2)
      DO mp1 = 1 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDVBK(m,n,Cvb,Work)
            DO i = 1 , Imid
               CALL DDVBT(m,n,Theta(i),Cvb,vbh)
               Vb(i,np1,mp1) = vbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCV(Nlat,Nlon,Abc)
      END SUBROUTINE DVBGIT1


      SUBROUTINE DWBGINT(Nlat,Nlon,Theta,Wwbin,Work)
      IMPLICIT NONE
      INTEGER imid , iw1 , Nlat , Nlon
      DOUBLE PRECISION Wwbin
      DIMENSION Wwbin(1)
      DOUBLE PRECISION Work(*) , Theta(*)
      imid = (Nlat+1)/2
      iw1 = 2*Nlat*imid + 1
!
!     theta is a double precision array with (nlat+1)/2 locations
!     nlat is the maximum value of n+1
!     the length of wwbin is 2*nlat*imid+3*((nlat-3)*nlat+2)/2
!     the length of work is 2*nlat+2
!
      CALL DWBGIT1(Nlat,Nlon,imid,Theta,Wwbin,Wwbin(iw1),Work,           &
                & Work(Nlat+2))
      END SUBROUTINE DWBGINT

      
      SUBROUTINE DWBGIT1(Nlat,Nlon,Imid,Theta,Wb,Abc,Cwb,Work)
      IMPLICIT NONE
      DOUBLE PRECISION Abc , Wb
      INTEGER i , Imid , m , mdo , mp1 , n , Nlat , Nlon , np1
!
!     abc must have 3*((nlat-3)*nlat+2)/2 locations
!     cwb and work must each have nlat+1 locations
!
      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<2 ) RETURN
      DO mp1 = 2 , mdo
         m = mp1 - 1
         DO np1 = mp1 , Nlat
            n = np1 - 1
            CALL DDWBK(m,n,Cwb,Work)
            DO i = 1 , Imid
               CALL DDWBT(m,n,Theta(i),Cwb,wbh)
               Wb(i,np1,m) = wbh
            ENDDO
         ENDDO
      ENDDO
      CALL DRABCW(Nlat,Nlon,Abc)
    END SUBROUTINE DWBGIT1
