!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file vhagc.f
!
!     this file contains code and documentation for subroutines
!     vhagc and vhagci
!
! ... files which must be loaded with vhagc.f
!
!     sphcom.f, hrfft.f, gaqd.f
!
!
!     subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
!    +                 mdab,ndab,wvhagc,lvhagc,work,lwork,ierror)
!
!     subroutine vhagc performs the vector spherical harmonic analysis
!     on the vector field (v,w) and stores the result in the arrays
!     br,bi,cr, and ci. v(i,j) and w(i,j) are the colatitudinal
!     (measured from the north pole) and east longitudinal components
!     respectively, located at the gaussian colatitude point theta(i)
!     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
!     representation of (v,w) is given at output parameters v,w in
!     subroutine vhsec.
!
!     input parameters
!
!     nlat   the number of points in the gaussian colatitude grid on the
!            full sphere. these lie in the interval (0,pi) and are computed
!            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
!            if nlat is odd the equator will be included as the grid point
!            theta((nlat+1)/2).  if nlat is even the equator will be
!            excluded as a grid point and will lie half way between
!            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
!            note: on the half sphere, the number of grid points in the
!            colatitudinal direction is nlat/2 if nlat is even or
!            (nlat+1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater
!            than zero. the axisymmetric case corresponds to nlon=1.
!            the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!     ityp   = 0  no symmetries exist about the equator. the analysis
!                 is performed on the entire sphere.  i.e. on the
!                 arrays v(i,j),w(i,j) for i=1,...,nlat and
!                 j=1,...,nlon.
!
!            = 1  no symmetries exist about the equator. the analysis
!                 is performed on the entire sphere.  i.e. on the
!                 arrays v(i,j),w(i,j) for i=1,...,nlat and
!                 j=1,...,nlon. the curl of (v,w) is zero. that is,
!                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
!                 the coefficients cr and ci are zero.
!
!            = 2  no symmetries exist about the equator. the analysis
!                 is performed on the entire sphere.  i.e. on the
!                 arrays v(i,j),w(i,j) for i=1,...,nlat and
!                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
!                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
!                 the coefficients br and bi are zero.
!
!            = 3  v is symmetric and w is antisymmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!            = 4  v is symmetric and w is antisymmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!                 the curl of (v,w) is zero. that is,
!                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
!                 the coefficients cr and ci are zero.
!
!            = 5  v is symmetric and w is antisymmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!                 the divergence of (v,w) is zero. i.e.,
!                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
!                 the coefficients br and bi are zero.
!
!            = 6  v is antisymmetric and w is symmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!            = 7  v is antisymmetric and w is symmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!                 the curl of (v,w) is zero. that is,
!                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
!                 the coefficients cr and ci are zero.
!
!            = 8  v is antisymmetric and w is symmetric about the
!                 equator. the analysis is performed on the northern
!                 hemisphere only.  i.e., if nlat is odd the analysis
!                 is performed on the arrays v(i,j),w(i,j) for
!                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
!                 even the analysis is performed on the the arrays
!                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!                 the divergence of (v,w) is zero. i.e.,
!                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
!                 the coefficients br and bi are zero.
!
!
!     nt     the number of analyses.  in the program that calls vhagc,
!            the arrays v,w,br,bi,cr, and ci can be three dimensional
!            in which case multiple analyses will be performed.
!            the third index is the analysis index which assumes the
!            values k=1,...,nt.  for a single analysis set nt=1. the
!            discription of the remaining parameters is simplified
!            by assuming that nt=1 or that all the arrays are two
!            dimensional.
!
!     v,w    two or three dimensional arrays (see input parameter nt)
!            that contain the vector function to be analyzed.
!            v is the colatitudnal component and w is the east
!            longitudinal component. v(i,j),w(i,j) contain the
!            components at colatitude theta(i) = (i-1)*pi/(nlat-1)
!            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
!            are defined above at the input parameter ityp.
!
!     idvw   the first dimension of the arrays v,w as it appears in
!            the program that calls vhagc. if ityp .le. 2 then idvw
!            must be at least nlat.  if ityp .gt. 2 and nlat is
!            even then idvw must be at least nlat/2. if ityp .gt. 2
!            and nlat is odd then idvw must be at least (nlat+1)/2.
!
!     jdvw   the second dimension of the arrays v,w as it appears in
!            the program that calls vhagc. jdvw must be at least nlon.
!
!     mdab   the first dimension of the arrays br,bi,cr, and ci as it
!            appears in the program that calls vhagc. mdab must be at
!            least min0(nlat,nlon/2) if nlon is even or at least
!            min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     ndab   the second dimension of the arrays br,bi,cr, and ci as it
!            appears in the program that calls vhagc. ndab must be at
!            least nlat.
!
!     wvhagc an array which must be initialized by subroutine vhagci.
!            once initialized, wvhagc can be used repeatedly by vhagc
!            as long as nlon and nlat remain unchanged.  wvhagc must
!            not be altered between calls of vhagc.
!
!     lvhagc the dimension of the array wvhagc as it appears in the
!            program that calls vhagc. define
!
!               l1 = min0(nlat,nlon/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            then lvhagc must be at least
!
!               4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15
!
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls vhagc. define
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            if ityp .le. 2 then lwork must be at least
!
!               2*nlat*(2*nlon*nt+3*l2)
!
!            if ityp .gt. 2 then lwork must be at least
!
!               2*l2*(2*nlon*nt+3*nlat)
!
!
!
!     **************************************************************
!
!     output parameters
!
!     br,bi  two or three dimensional arrays (see input parameter nt)
!     cr,ci  that contain the vector spherical harmonic coefficients
!            in the spectral representation of v(i,j) and w(i,j) given
!            in the discription of subroutine vhsec. br(mp1,np1),
!            bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed
!            for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat
!            and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or
!            mmax=min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of ityp
!            = 4  error in the specification of nt
!            = 5  error in the specification of idvw
!            = 6  error in the specification of jdvw
!            = 7  error in the specification of mdab
!            = 8  error in the specification of ndab
!            = 9  error in the specification of lvhagc
!            = 10 error in the specification of lwork
!
! ****************************************************************
!
!     subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror)
!
!     subroutine vhagci initializes the array wvhagc which can then be
!     used repeatedly by subroutine vhagc until nlat or nlon is changed.
!
!     input parameters
!
!     nlat   the number of points in the gaussian colatitude grid on the
!            full sphere. these lie in the interval (0,pi) and are computed
!            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
!            if nlat is odd the equator will be included as the grid point
!            theta((nlat+1)/2).  if nlat is even the equator will be
!            excluded as a grid point and will lie half way between
!            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
!            note: on the half sphere, the number of grid points in the
!            colatitudinal direction is nlat/2 if nlat is even or
!            (nlat+1)/2 if nlat is odd.
!
!     nlon   the number of distinct londitude points.  nlon determines
!            the grid increment in longitude as 2*pi/nlon. for example
!            nlon = 72 for a five degree grid. nlon must be greater
!            than zero. the axisymmetric case corresponds to nlon=1.
!            the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!     lvhagc the dimension of the array wvhagc as it appears in the
!            program that calls vhagci.  define
!
!               l1 = min0(nlat,nlon/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            and
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!            then lvhagc must be at least
!
!               4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15
!
!
!     dwork  a double precision work array that does not need to be saved
!
!     ldwork the dimension of the array dwork as it appears in the
!            program that calls vhagci. ldwork must be at least
!
!               2*nlat*(nlat+1)+1
!
!
!     **************************************************************
!
!     output parameters
!
!     wvhagc an array which is initialized for use by subroutine vhagc.
!            once initialized, wvhagc can be used repeatedly by vhagc
!            as long as nlat and nlon remain unchanged.  wvhagc must not
!            be altered between calls of vhagc.
!
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of lvhagc
!            = 4  error in the specification of lwork
!
      SUBROUTINE VHAGC(Nlat,Nlon,Ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,Cr,Ci,Mdab,&
                     & Ndab,Wvhagc,Lvhagc,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL Bi , Br , Ci , Cr , V , W , Work , Wvhagc
      INTEGER idv , Idvw , Ierror , imid , ist , Ityp , iw1 , iw2 ,     &
            & iw3 , iw4 , iw5 , Jdvw , jw1 , jw2 , jw3 , labc , lnl ,   &
            & Lvhagc , Lwork , lwzvin
      INTEGER lzz1 , Mdab , mmax , Ndab , Nlat , Nlon , Nt
      DIMENSION V(Idvw,Jdvw,1) , W(Idvw,Jdvw,1) , Br(Mdab,Ndab,1) ,     &
              & Bi(Mdab,Ndab,1) , Cr(Mdab,Ndab,1) , Ci(Mdab,Ndab,1) ,   &
              & Work(1) , Wvhagc(1)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      IF ( Ityp<0 .OR. Ityp>8 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Ityp<=2 .AND. Idvw<Nlat) .OR. (Ityp>2 .AND. Idvw<imid) )    &
         & RETURN
      Ierror = 6
      IF ( Jdvw<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
      lzz1 = 2*Nlat*imid
      labc = 3*(MAX0(mmax-2,0)*(Nlat+Nlat-mmax-1))/2
      IF ( Lvhagc<2*(lzz1+labc)+Nlon+imid+15 ) RETURN
      Ierror = 10
      IF ( Ityp<=2 .AND. Lwork<Nlat*(4*Nlon*Nt+6*imid) ) RETURN
      IF ( Ityp>2 .AND. Lwork<imid*(4*Nlon*Nt+6*Nlat) ) RETURN
      Ierror = 0
      idv = Nlat
      IF ( Ityp>2 ) idv = imid
      lnl = Nt*idv*Nlon
      ist = 0
      IF ( Ityp<=2 ) ist = imid
      iw1 = ist + 1
      iw2 = lnl + 1
      iw3 = iw2 + ist
      iw4 = iw2 + lnl
      iw5 = iw4 + 3*imid*Nlat
      lwzvin = lzz1 + labc
      jw1 = (Nlat+1)/2 + 1
      jw2 = jw1 + lwzvin
      jw3 = jw2 + lwzvin
      CALL VHAGC1(Nlat,Nlon,Ityp,Nt,imid,Idvw,Jdvw,V,W,Mdab,Ndab,Br,Bi, &
                & Cr,Ci,idv,Work,Work(iw1),Work(iw2),Work(iw3),Work(iw4)&
                & ,Work(iw5),Wvhagc,Wvhagc(jw1),Wvhagc(jw2),Wvhagc(jw3))
      END SUBROUTINE VHAGC


      SUBROUTINE VHAGCI(Nlat,Nlon,Wvhagc,Lvhagc,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , iw2 , iw3 , iwrk , jw1 , jw2 , jw3 ,&
            & labc , Ldwork , Lvhagc , lwk , lwvbin , lzz1 , mmax ,     &
            & Nlat , Nlon
      REAL Wvhagc
      DIMENSION Wvhagc(1)
      DOUBLE PRECISION Dwork(*)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      imid = (Nlat+1)/2
      lzz1 = 2*Nlat*imid
      mmax = MIN0(Nlat,(Nlon+1)/2)
      labc = 3*(MAX0(mmax-2,0)*(Nlat+Nlat-mmax-1))/2
      imid = (Nlat+1)/2
      IF ( Lvhagc<2*(lzz1+labc)+Nlon+imid+15 ) RETURN
      Ierror = 4
      IF ( Ldwork<2*Nlat*(Nlat+1)+1 ) RETURN
      Ierror = 0
!
!     compute gaussian points in first nlat+1 words of dwork
!     double precision
!
      lwk = Nlat*(Nlat+2)
 
      jw1 = 1
!     jw2 = jw1+nlat+nlat
!     jw3 = jw2+nlat+nlat
      jw2 = jw1 + Nlat
      jw3 = jw2 + Nlat
      CALL GAQD(Nlat,Dwork(jw1),Dwork(jw2),Dwork(jw3),lwk,Ierror)
      imid = (Nlat+1)/2
!
!     set first imid words of double precision weights in dwork
!     as single precision in first imid words of wvhagc
!
      CALL SETWTS(imid,Dwork(Nlat+1),Wvhagc)
!
!     first nlat+1 words of dwork contain  double theta
!
!     iwrk = nlat+2
      iwrk = (Nlat+1)/2 + 1
      iw1 = imid + 1
      CALL VBGINT(Nlat,Nlon,Dwork,Wvhagc(iw1),Dwork(iwrk))
      lwvbin = lzz1 + labc
      iw2 = iw1 + lwvbin
      CALL WBGINT(Nlat,Nlon,Dwork,Wvhagc(iw2),Dwork(iwrk))
      iw3 = iw2 + lwvbin
      CALL HRFFTI(Nlon,Wvhagc(iw3))
      END SUBROUTINE VHAGCI


      SUBROUTINE SETWTS(Imid,Dwts,Wts)
      IMPLICIT NONE
      INTEGER i , Imid
      REAL Wts
!
!     set first imid =(nlat+1)/2 of double precision weights in dwts
!     as single precision in wts
!
      DIMENSION Dwts(Imid) , Wts(Imid)
      DOUBLE PRECISION Dwts
      DO i = 1 , Imid
         Wts(i) = Dwts(i)
      ENDDO
      END SUBROUTINE SETWTS


      SUBROUTINE DVHAGC(Nlat,Nlon,Ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,Cr,Ci,Mdab,&
           & Ndab,Wvhagc,Lvhagc,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION Bi , Br , Ci , Cr , V , W , Work , Wvhagc
      INTEGER idv , Idvw , Ierror , imid , ist , Ityp , iw1 , iw2 ,     &
            & iw3 , iw4 , iw5 , Jdvw , jw1 , jw2 , jw3 , labc , lnl ,   &
            & Lvhagc , Lwork , lwzvin
      INTEGER lzz1 , Mdab , mmax , Ndab , Nlat , Nlon , Nt
      DIMENSION V(Idvw,Jdvw,1) , W(Idvw,Jdvw,1) , Br(Mdab,Ndab,1) ,     &
              & Bi(Mdab,Ndab,1) , Cr(Mdab,Ndab,1) , Ci(Mdab,Ndab,1) ,   &
              & Work(1) , Wvhagc(1)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      IF ( Ityp<0 .OR. Ityp>8 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Ityp<=2 .AND. Idvw<Nlat) .OR. (Ityp>2 .AND. Idvw<imid) )    &
         & RETURN
      Ierror = 6
      IF ( Jdvw<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
      lzz1 = 2*Nlat*imid
      labc = 3*(MAX0(mmax-2,0)*(Nlat+Nlat-mmax-1))/2
      IF ( Lvhagc<2*(lzz1+labc)+Nlon+imid+15 ) RETURN
      Ierror = 10
      IF ( Ityp<=2 .AND. Lwork<Nlat*(4*Nlon*Nt+6*imid) ) RETURN
      IF ( Ityp>2 .AND. Lwork<imid*(4*Nlon*Nt+6*Nlat) ) RETURN
      Ierror = 0
      idv = Nlat
      IF ( Ityp>2 ) idv = imid
      lnl = Nt*idv*Nlon
      ist = 0
      IF ( Ityp<=2 ) ist = imid
      iw1 = ist + 1
      iw2 = lnl + 1
      iw3 = iw2 + ist
      iw4 = iw2 + lnl
      iw5 = iw4 + 3*imid*Nlat
      lwzvin = lzz1 + labc
      jw1 = (Nlat+1)/2 + 1
      jw2 = jw1 + lwzvin
      jw3 = jw2 + lwzvin
      CALL DVHAGC1(Nlat,Nlon,Ityp,Nt,imid,Idvw,Jdvw,V,W,Mdab,Ndab,Br,Bi, &
                & Cr,Ci,idv,Work,Work(iw1),Work(iw2),Work(iw3),Work(iw4)&
                & ,Work(iw5),Wvhagc,Wvhagc(jw1),Wvhagc(jw2),Wvhagc(jw3))
      END SUBROUTINE DVHAGC


      SUBROUTINE DVHAGCI(Nlat,Nlon,Wvhagc,Lvhagc,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , iw2 , iw3 , iwrk , jw1 , jw2 , jw3 ,&
            & labc , Ldwork , Lvhagc , lwk , lwvbin , lzz1 , mmax ,     &
            & Nlat , Nlon
      DOUBLE PRECISION Wvhagc
      DIMENSION Wvhagc(1)
      DOUBLE PRECISION Dwork(*)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      imid = (Nlat+1)/2
      lzz1 = 2*Nlat*imid
      mmax = MIN0(Nlat,(Nlon+1)/2)
      labc = 3*(MAX0(mmax-2,0)*(Nlat+Nlat-mmax-1))/2
      imid = (Nlat+1)/2
      IF ( Lvhagc<2*(lzz1+labc)+Nlon+imid+15 ) RETURN
      Ierror = 4
      IF ( Ldwork<2*Nlat*(Nlat+1)+1 ) RETURN
      Ierror = 0
!
!     compute gaussian points in first nlat+1 words of dwork
!     double precision
!
      lwk = Nlat*(Nlat+2)
 
      jw1 = 1
!     jw2 = jw1+nlat+nlat
!     jw3 = jw2+nlat+nlat
      jw2 = jw1 + Nlat
      jw3 = jw2 + Nlat
      CALL DGAQD(Nlat,Dwork(jw1),Dwork(jw2),Dwork(jw3),lwk,Ierror)
      imid = (Nlat+1)/2
!
!     set first imid words of double precision weights in dwork
!     as single precision in first imid words of wvhagc
!
      CALL DSETWTS(imid,Dwork(Nlat+1),Wvhagc)
!
!     first nlat+1 words of dwork contain  double theta
!
!     iwrk = nlat+2
      iwrk = (Nlat+1)/2 + 1
      iw1 = imid + 1
      CALL DVBGINT(Nlat,Nlon,Dwork,Wvhagc(iw1),Dwork(iwrk))
      lwvbin = lzz1 + labc
      iw2 = iw1 + lwvbin
      CALL DWBGINT(Nlat,Nlon,Dwork,Wvhagc(iw2),Dwork(iwrk))
      iw3 = iw2 + lwvbin
      CALL DHRFFTI(Nlon,Wvhagc(iw3))
      END SUBROUTINE DVHAGCI


      SUBROUTINE DSETWTS(Imid,Dwts,Wts)
      IMPLICIT NONE
      INTEGER i , Imid
      DOUBLE PRECISION Wts
!
!     set first imid =(nlat+1)/2 of double precision weights in dwts
!     as single precision in wts
!
      DIMENSION Dwts(Imid) , Wts(Imid)
      DOUBLE PRECISION Dwts
      DO i = 1 , Imid
         Wts(i) = Dwts(i)
      ENDDO
      END SUBROUTINE DSETWTS
      
      SUBROUTINE DVHAGC1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,   &
                        BR,BI,CR,CI,IDV,VE,VO,WE,WO,VB,WB,WTS,WVBIN,   &
                        WWBIN,WRFFT)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VE
      DOUBLE PRECISION VO
      DOUBLE PRECISION WE
      DOUBLE PRECISION WO
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WTS
      DOUBLE PRECISION WVBIN
      DOUBLE PRECISION WWBIN
      DOUBLE PRECISION WRFFT
      DOUBLE PRECISION TSN
      DOUBLE PRECISION FSN
      DOUBLE PRECISION TV
      DOUBLE PRECISION TW
      DOUBLE PRECISION TVO1
      DOUBLE PRECISION TVO2
      DOUBLE PRECISION TVE1
      DOUBLE PRECISION TVE2
      DOUBLE PRECISION TWO1
      DOUBLE PRECISION TWO2
      DOUBLE PRECISION TWE1
      DOUBLE PRECISION TWE2
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),   &
               BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),  &
               VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),  &
               WO(IDV,NLON,1),WTS(*),WVBIN(1),WWBIN(1),WRFFT(1),  &
               VB(IMID,NLAT,3),WB(IMID,NLAT,3)  

      NLP1 = NLAT + 1
      TSN = 2.D0/NLON
      FSN = 4.D0/NLON
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      IF (ITYP.GT.2) THEN
         DO K = 1,NT
            DO  I = 1,IMM1
               DO  J = 1,NLON
                  VE(I,J,K) = FSN*V(I,J,K)
                  VO(I,J,K) = FSN*V(I,J,K)
                  WE(I,J,K) = FSN*W(I,J,K)
                  WO(I,J,K) = FSN*W(I,J,K)
               END DO
            END DO
         END DO
      ELSE
         DO  K = 1,NT
            DO I = 1,IMM1
              DO  J = 1,NLON
                  VE(I,J,K) = TSN* (V(I,J,K)+V(NLP1-I,J,K))
                  VO(I,J,K) = TSN* (V(I,J,K)-V(NLP1-I,J,K))
                  WE(I,J,K) = TSN* (W(I,J,K)+W(NLP1-I,J,K))
                  WO(I,J,K) = TSN* (W(I,J,K)-W(NLP1-I,J,K))
               END DO
            END DO
         END DO
      ENDIF
      IF (MLAT.EQ.0) GO TO 7
      DO  K = 1,NT
          DO J = 1,NLON
              VE(IMID,J,K) = TSN*V(IMID,J,K)
              WE(IMID,J,K) = TSN*W(IMID,J,K)
           END DO
        END DO
    7  DO K = 1,NT
          CALL DHRFFTF(IDV,NLON,VE(1,1,K),IDV,WRFFT,VB)
          CALL DHRFFTF(IDV,NLON,WE(1,1,K),IDV,WRFFT,VB)
      END DO
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
      IF (ITYP.EQ.2 .OR. ITYP.EQ.5 .OR. ITYP.EQ.8) GO TO 11
      DO K = 1,NT
          DO  MP1 = 1,MMAX
              DO  NP1 = MP1,NLAT
                  BR(MP1,NP1,K) = 0.D0
                  BI(MP1,NP1,K) = 0.D0
               END DO
            END DO
         END DO
   10 CONTINUE
   11 IF (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.7) GO TO 13
      DO K = 1,NT
          DO  MP1 = 1,MMAX
              DO  NP1 = MP1,NLAT
                  CR(MP1,NP1,K) = 0.D0
                  CI(MP1,NP1,K) = 0.D0
               END DO
            END DO
         END DO
   12 CONTINUE
   13 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
!
!     case ityp=0 ,  no symmetries
!
    1 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO 15 K = 1,NT
          DO  I = 1,IMID
              TV = VE(I,1,K)*WTS(I)
              TW = WE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
               END DO
            END DO
   15 CONTINUE
      DO 16 K = 1,NT
          DO 1016 I = 1,IMM1
              TV = VO(I,1,K)*WTS(I)
              TW = WO(I,1,K)*WTS(I)
              DO 10016 NP1 = 3,NDO1,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
10016         CONTINUE
 1016     CONTINUE
   16 CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 20 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 17
          DO K = 1,NT
              DO  I = 1,IMM1
!
!     set temps to optimize quadrature
!
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) + &
     &                                VB(I,NP1,IV)*TVO2 +  &
     &                                WB(I,NP1,IW)*TWE1 
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) + &
     &                                VB(I,NP1,IV)*TVO1 - &
     &                                WB(I,NP1,IW)*TWE2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                                VB(I,NP1,IV)*TWO1 - &
     &                                WB(I,NP1,IW)*TVE2
                   END DO
                END DO
             END DO
   23     CONTINUE

          IF (MLAT.EQ.0) GO TO 17
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +                &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
   17     IF (MP2.GT.NDO2) GO TO 20
          DO 21 K = 1,NT
              DO 1021 I = 1,IMM1
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO 10021 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVE2 + &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVE1 - &
     &                                WB(I,NP1,IW)*TWO2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -   &
     &                                 VB(I,NP1,IV)*TWE2 +  &
     &                                WB(I,NP1,IW)*TVO1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                                VB(I,NP1,IV)*TWE1 - &
     &                                WB(I,NP1,IW)*TVO2
10021             CONTINUE
 1021         CONTINUE
   21     CONTINUE

          IF (MLAT.EQ.0) GO TO 20
          I = IMID
          DO 22 K = 1,NT
              DO 1022 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +  &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
     &                            VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
     &                            VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
 1022         CONTINUE
   22     CONTINUE
   20 CONTINUE
      RETURN
!
!     case ityp=1 ,  no symmetries but cr and ci equal zero
!
  100 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TV = VE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                 BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
              END DO
           END DO
        END DO
  115 CONTINUE
      DO K = 1,NT
          DO I = 1,IMM1
              TV = VO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                 BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
              END DO
           END DO
        END DO
  116 CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 120 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 117
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +     &
     &                                VB(I,NP1,IV)*TVO2 + &
     &                                WB(I,NP1,IW)*TWE1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +     &
     &                                VB(I,NP1,IV)*TVO1 - &
     &                                WB(I,NP1,IW)*TWE2
                   END DO
                END DO
             END DO
  123     CONTINUE
          IF (MLAT.EQ.0) GO TO 117
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  124     CONTINUE
  117     IF (MP2.GT.NDO2) GO TO 120
          DO K = 1,NT
              DO  I = 1,IMM1
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE2 +  &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE1 -  &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
             END DO
                      
          IF (MLAT.EQ.0) GO TO 120
          I = IMID
          DO K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  120 CONTINUE
      RETURN
!
!     case ityp=2 ,  no symmetries but br and bi equal zero
!
  200 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TW = WE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                 CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
              END DO
           END DO
        END DO
  215 CONTINUE
      DO  K = 1,NT
          DO  I = 1,IMM1
              TW = WO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
               END DO
            END DO
         END DO
216               CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 220 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 217
          DO K = 1,NT
              DO  I = 1,IMM1
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -    &
     &                                VB(I,NP1,IV)*TWO1 -  &
     &                                WB(I,NP1,IW)*TVE2

                   END DO
                END DO
             END DO
          IF (MLAT.EQ.0) GO TO 217
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  217     IF (MP2.GT.NDO2) GO TO 220
          DO K = 1,NT
              DO I = 1,IMM1
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWE2 + &
     &                                WB(I,NP1,IW)*TVO1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
     &                                VB(I,NP1,IV)*TWE1 -  &
     &                                WB(I,NP1,IW)*TVO2
                   END DO
                END DO
             END DO
221                   CONTINUE
                      
          IF (MLAT.EQ.0) GO TO 220
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -   &
                       VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
                       VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  220 CONTINUE
      RETURN
!
!     case ityp=3 ,  v even , w odd
!
  300 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TV = VE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
             END DO
          END DO
       END DO
      DO K = 1,NT
          DO  I = 1,IMM1
              TW = WO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
               END DO
            END DO
         END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 320 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 317
          DO K = 1,NT
              DO I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO1 - &
     &                                WB(I,NP1,IW)*TVE2
                   END DO
                END DO
             END DO
             
          IF (MLAT.EQ.0) GO TO 317
          I = IMID
          DO K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +     &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -     &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  317     IF (MP2.GT.NDO2) GO TO 320
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +       &
     &                                VB(I,NP1,IV)*TVE2 +   &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +       &
     &                                VB(I,NP1,IV)*TVE1 -   &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
             END DO
          IF (MLAT.EQ.0) GO TO 320
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  320 CONTINUE
      RETURN
!
!     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
!
  400 CALL DVBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TV = VE(I,1,K)*WTS(I)
            DO  NP1 = 2,NDO2,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 420 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 420
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE2 +  &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE1 -  &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
                END DO
          IF (MLAT.EQ.0) GO TO 420
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
            
  420 CONTINUE
      RETURN
!
!     case ityp=5   v even, w odd, and br and bi equal zero
!
  500 CALL DVBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMM1
             TW = WO(I,1,K)*WTS(I)
             DO  NP1 = 3,NDO1,2
                CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
             END DO
          END DO
       END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 520 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 520
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -       &
                           VB(I,NP1,IV)*TWO2 +   &
                           WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -       &
                           VB(I,NP1,IV)*TWO1 -   &
                           WB(I,NP1,IW)*TVE2
                   END DO
                END DO 
                END DO
          IF (MLAT.EQ.0) GO TO 520
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP1,NDO1,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) +      &
                     WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                     WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
  520 CONTINUE
      RETURN
!
!     case ityp=6 ,  v odd , w even
!
  600 CALL DVBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TW = WE(I,1,K)*WTS(I)
            DO NP1 = 2,NDO2,2
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
      END DO
      DO  K = 1,NT
         DO  I = 1,IMM1
            TV = VO(I,1,K)*WTS(I)
            DO  NP1 = 3,NDO1,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 620 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 617
          DO  K = 1,NT
             DO I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP1,NDO1,2
                   BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
                        VB(I,NP1,IV)*TVO2 +  &
                        WB(I,NP1,IW)*TWE1
                   BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
                        VB(I,NP1,IV)*TVO1 -  &
                        WB(I,NP1,IW)*TWE2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 617
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP1,NDO1,2
                BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
                     WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
                     WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
                  
  617     IF (MP2.GT.NDO2) GO TO 620
          DO  K = 1,NT
             DO  I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP2,NDO2,2
                   CR(MP1,NP1,K) = CR(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE2 +  &
                        WB(I,NP1,IW)*TVO1
                   CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE1 -  &
                        WB(I,NP1,IW)*TVO2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 620
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP2,NDO2,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
             END DO
          END DO
  620 CONTINUE
      RETURN
!
!     case ityp=7   v odd, w even, and cr and ci equal zero
!
  700 CALL DVBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMM1
            TV = VO(I,1,K)*WTS(I)
            DO  NP1 = 3,NDO1,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 720 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 720
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVO2 +  &
     &                                WB(I,NP1,IW)*TWE1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +   &
     &                                VB(I,NP1,IV)*TVO1 -  &
     &                                WB(I,NP1,IW)*TWE2   
                 END DO
              END DO
          END DO
          IF (MLAT.EQ.0) GO TO 720
          I = IMID
          DO K = 1,NT
             DO  NP1 = MP1,NDO1,2
                 BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                 BI(MP1,NP1,K) = BI(MP1,NP1,K) -  &
     &                           WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
720  CONTINUE
      RETURN
!
!     case ityp=8   v odd, w even, and both br and bi equal zero
!
  800 CALL DVBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TW = WE(I,1,K)*WTS(I)
            DO  NP1 = 2,NDO2,2
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 820 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL DVBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL DWBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 820
          DO  K = 1,NT
             DO  I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP2,NDO2,2
                   CR(MP1,NP1,K) = CR(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE2 +  &
                        WB(I,NP1,IW)*TVO1A
                   CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE1 -  &
                        WB(I,NP1,IW)*TVO2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 820
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP2,NDO2,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
             END DO
          END DO
  820 CONTINUE
      RETURN
      END SUBROUTINE DVHAGC1



      SUBROUTINE VHAGC1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,   &
                        BR,BI,CR,CI,IDV,VE,VO,WE,WO,VB,WB,WTS,WVBIN,   &
                        WWBIN,WRFFT)
      REAL V
      REAL W
      REAL BR
      REAL BI
      REAL CR
      REAL CI
      REAL VE
      REAL VO
      REAL WE
      REAL WO
      REAL VB
      REAL WB
      REAL WTS
      REAL WVBIN
      REAL WWBIN
      REAL WRFFT
      REAL TSN
      REAL FSN
      REAL TV
      REAL TW
      REAL TVO1
      REAL TVO2
      REAL TVE1
      REAL TVE2
      REAL TWO1
      REAL TWO2
      REAL TWE1
      REAL TWE2
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),   &
               BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),  &
               VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),  &
               WO(IDV,NLON,1),WTS(*),WVBIN(1),WWBIN(1),WRFFT(1),  &
               VB(IMID,NLAT,3),WB(IMID,NLAT,3)  

      NLP1 = NLAT + 1
      TSN = 2.D0/NLON
      FSN = 4.D0/NLON
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      IF (ITYP.GT.2) THEN
         DO K = 1,NT
            DO  I = 1,IMM1
               DO  J = 1,NLON
                  VE(I,J,K) = FSN*V(I,J,K)
                  VO(I,J,K) = FSN*V(I,J,K)
                  WE(I,J,K) = FSN*W(I,J,K)
                  WO(I,J,K) = FSN*W(I,J,K)
               END DO
            END DO
         END DO
      ELSE
         DO  K = 1,NT
            DO I = 1,IMM1
              DO  J = 1,NLON
                  VE(I,J,K) = TSN* (V(I,J,K)+V(NLP1-I,J,K))
                  VO(I,J,K) = TSN* (V(I,J,K)-V(NLP1-I,J,K))
                  WE(I,J,K) = TSN* (W(I,J,K)+W(NLP1-I,J,K))
                  WO(I,J,K) = TSN* (W(I,J,K)-W(NLP1-I,J,K))
               END DO
            END DO
         END DO
      ENDIF
      IF (MLAT.EQ.0) GO TO 7
      DO  K = 1,NT
          DO J = 1,NLON
              VE(IMID,J,K) = TSN*V(IMID,J,K)
              WE(IMID,J,K) = TSN*W(IMID,J,K)
           END DO
        END DO
    7  DO K = 1,NT
          CALL HRFFTF(IDV,NLON,VE(1,1,K),IDV,WRFFT,VB)
          CALL HRFFTF(IDV,NLON,WE(1,1,K),IDV,WRFFT,VB)
      END DO
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
      IF (ITYP.EQ.2 .OR. ITYP.EQ.5 .OR. ITYP.EQ.8) GO TO 11
      DO K = 1,NT
          DO  MP1 = 1,MMAX
              DO  NP1 = MP1,NLAT
                  BR(MP1,NP1,K) = 0.D0
                  BI(MP1,NP1,K) = 0.D0
               END DO
            END DO
         END DO
   10 CONTINUE
   11 IF (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.7) GO TO 13
      DO K = 1,NT
          DO  MP1 = 1,MMAX
              DO  NP1 = MP1,NLAT
                  CR(MP1,NP1,K) = 0.D0
                  CI(MP1,NP1,K) = 0.D0
               END DO
            END DO
         END DO
   12 CONTINUE
   13 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
!
!     case ityp=0 ,  no symmetries
!
    1 CALL VBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TV = VE(I,1,K)*WTS(I)
            TW = WE(I,1,K)*WTS(I)
            DO  NP1 = 2,NDO2,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
      END DO
      DO 16 K = 1,NT
         DO  I = 1,IMM1
            TV = VO(I,1,K)*WTS(I)
            TW = WO(I,1,K)*WTS(I)
            DO  NP1 = 3,NDO1,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
   16 CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 20 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 17
          DO K = 1,NT
              DO  I = 1,IMM1
!
!     set temps to optimize quadrature
!
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) + &
     &                                VB(I,NP1,IV)*TVO2 +  &
     &                                WB(I,NP1,IW)*TWE1 
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) + &
     &                                VB(I,NP1,IV)*TVO1 - &
     &                                WB(I,NP1,IW)*TWE2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                                VB(I,NP1,IV)*TWO1 - &
     &                                WB(I,NP1,IW)*TVE2
                   END DO
                END DO
             END DO
   23     CONTINUE

          IF (MLAT.EQ.0) GO TO 17
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +                &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
   17     IF (MP2.GT.NDO2) GO TO 20
          DO 21 K = 1,NT
              DO 1021 I = 1,IMM1
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO 10021 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVE2 + &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVE1 - &
     &                                WB(I,NP1,IW)*TWO2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -   &
     &                                 VB(I,NP1,IV)*TWE2 +  &
     &                                WB(I,NP1,IW)*TVO1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                                VB(I,NP1,IV)*TWE1 - &
     &                                WB(I,NP1,IW)*TVO2
10021             CONTINUE
 1021         CONTINUE
   21     CONTINUE

          IF (MLAT.EQ.0) GO TO 20
          I = IMID
          DO 22 K = 1,NT
              DO 1022 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +  &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
     &                            VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
     &                            VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
 1022         CONTINUE
   22     CONTINUE
   20 CONTINUE
      RETURN
!
!     case ityp=1 ,  no symmetries but cr and ci equal zero
!
  100 CALL VBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TV = VE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                 BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
              END DO
           END DO
        END DO
  115 CONTINUE
      DO K = 1,NT
          DO I = 1,IMM1
              TV = VO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                 BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
              END DO
           END DO
        END DO
  116 CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 120 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 117
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +     &
     &                                VB(I,NP1,IV)*TVO2 + &
     &                                WB(I,NP1,IW)*TWE1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +     &
     &                                VB(I,NP1,IV)*TVO1 - &
     &                                WB(I,NP1,IW)*TWE2
                   END DO
                END DO
             END DO
  123     CONTINUE
          IF (MLAT.EQ.0) GO TO 117
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  124     CONTINUE
  117     IF (MP2.GT.NDO2) GO TO 120
          DO K = 1,NT
              DO  I = 1,IMM1
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE2 +  &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE1 -  &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
             END DO
                      
          IF (MLAT.EQ.0) GO TO 120
          I = IMID
          DO K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  120 CONTINUE
      RETURN
!
!     case ityp=2 ,  no symmetries but br and bi equal zero
!
  200 CALL VBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TW = WE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                 CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
              END DO
           END DO
        END DO
  215 CONTINUE
      DO  K = 1,NT
          DO  I = 1,IMM1
              TW = WO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
               END DO
            END DO
         END DO
216               CONTINUE
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 220 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 217
          DO K = 1,NT
              DO  I = 1,IMM1
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -    &
     &                                VB(I,NP1,IV)*TWO1 -  &
     &                                WB(I,NP1,IW)*TVE2

                   END DO
                END DO
             END DO
          IF (MLAT.EQ.0) GO TO 217
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  217     IF (MP2.GT.NDO2) GO TO 220
          DO K = 1,NT
              DO I = 1,IMM1
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWE2 + &
     &                                WB(I,NP1,IW)*TVO1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
     &                                VB(I,NP1,IV)*TWE1 -  &
     &                                WB(I,NP1,IW)*TVO2
                   END DO
                END DO
             END DO
221                   CONTINUE
                      
          IF (MLAT.EQ.0) GO TO 220
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -   &
                       VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -   &
                       VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  220 CONTINUE
      RETURN
!
!     case ityp=3 ,  v even , w odd
!
  300 CALL VBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMID
              TV = VE(I,1,K)*WTS(I)
              DO  NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
             END DO
          END DO
       END DO
      DO K = 1,NT
          DO  I = 1,IMM1
              TW = WO(I,1,K)*WTS(I)
              DO  NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
               END DO
            END DO
         END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 320 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 317
          DO K = 1,NT
              DO I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO2 + &
     &                                WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -     &
     &                                VB(I,NP1,IV)*TWO1 - &
     &                                WB(I,NP1,IW)*TVE2
                   END DO
                END DO
             END DO
             
          IF (MLAT.EQ.0) GO TO 317
          I = IMID
          DO K = 1,NT
              DO  NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +     &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -     &
     &                            WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
               END DO
            END DO
  317     IF (MP2.GT.NDO2) GO TO 320
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +       &
     &                                VB(I,NP1,IV)*TVE2 +   &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +       &
     &                                VB(I,NP1,IV)*TVE1 -   &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
             END DO
          IF (MLAT.EQ.0) GO TO 320
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
  320 CONTINUE
      RETURN
!
!     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
!
  400 CALL VBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TV = VE(I,1,K)*WTS(I)
            DO  NP1 = 2,NDO2,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 420 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 420
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE2 +  &
     &                                WB(I,NP1,IW)*TWO1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
     &                                VB(I,NP1,IV)*TVE1 -  &
     &                                WB(I,NP1,IW)*TWO2
                   END DO
                END DO
                END DO
          IF (MLAT.EQ.0) GO TO 420
          I = IMID
          DO  K = 1,NT
              DO  NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-2,K)*WTS(I)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +    &
     &                            VB(I,NP1,IV)*VE(I,2*MP1-1,K)*WTS(I)
               END DO
            END DO
            
  420 CONTINUE
      RETURN
!
!     case ityp=5   v even, w odd, and br and bi equal zero
!
  500 CALL VBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
          DO  I = 1,IMM1
             TW = WO(I,1,K)*WTS(I)
             DO  NP1 = 3,NDO1,2
                CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
             END DO
          END DO
       END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 520 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 520
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWO1 = WO(I,2*MP1-1,K)*WTS(I)
                  TWO2 = WO(I,2*MP1-2,K)*WTS(I)
                  TVE1 = VE(I,2*MP1-1,K)*WTS(I)
                  TVE2 = VE(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -       &
                           VB(I,NP1,IV)*TWO2 +   &
                           WB(I,NP1,IW)*TVE1
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -       &
                           VB(I,NP1,IV)*TWO1 -   &
                           WB(I,NP1,IW)*TVE2
                   END DO
                END DO 
                END DO
          IF (MLAT.EQ.0) GO TO 520
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP1,NDO1,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) +      &
                     WB(I,NP1,IW)*VE(I,2*MP1-1,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                     WB(I,NP1,IW)*VE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
  520 CONTINUE
      RETURN
!
!     case ityp=6 ,  v odd , w even
!
  600 CALL VBIN(0,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TW = WE(I,1,K)*WTS(I)
            DO NP1 = 2,NDO2,2
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
      END DO
      DO  K = 1,NT
         DO  I = 1,IMM1
            TV = VO(I,1,K)*WTS(I)
            DO  NP1 = 3,NDO1,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 620 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(0,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(0,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 617
          DO  K = 1,NT
             DO I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP1,NDO1,2
                   BR(MP1,NP1,K) = BR(MP1,NP1,K) +      &
                        VB(I,NP1,IV)*TVO2 +  &
                        WB(I,NP1,IW)*TWE1
                   BI(MP1,NP1,K) = BI(MP1,NP1,K) +      &
                        VB(I,NP1,IV)*TVO1 -  &
                        WB(I,NP1,IW)*TWE2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 617
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP1,NDO1,2
                BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
                     WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                BI(MP1,NP1,K) = BI(MP1,NP1,K) -   &
                     WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
                  
  617     IF (MP2.GT.NDO2) GO TO 620
          DO  K = 1,NT
             DO  I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP2,NDO2,2
                   CR(MP1,NP1,K) = CR(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE2 +  &
                        WB(I,NP1,IW)*TVO1
                   CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE1 -  &
                        WB(I,NP1,IW)*TVO2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 620
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP2,NDO2,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
             END DO
          END DO
  620 CONTINUE
      RETURN
!
!     case ityp=7   v odd, w even, and cr and ci equal zero
!
  700 CALL VBIN(2,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMM1
            TV = VO(I,1,K)*WTS(I)
            DO  NP1 = 3,NDO1,2
               BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1,IV)*TV
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 720 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(2,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(2,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP1.GT.NDO1) GO TO 720
          DO  K = 1,NT
              DO  I = 1,IMM1
                  TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                  TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                  TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                  TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                  DO  NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                                VB(I,NP1,IV)*TVO2 +  &
     &                                WB(I,NP1,IW)*TWE1
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +   &
     &                                VB(I,NP1,IV)*TVO1 -  &
     &                                WB(I,NP1,IW)*TWE2   
                 END DO
              END DO
          END DO
          IF (MLAT.EQ.0) GO TO 720
          I = IMID
          DO K = 1,NT
             DO  NP1 = MP1,NDO1,2
                 BR(MP1,NP1,K) = BR(MP1,NP1,K) +  &
     &                            WB(I,NP1,IW)*WE(I,2*MP1-1,K)*WTS(I)
                 BI(MP1,NP1,K) = BI(MP1,NP1,K) -  &
     &                           WB(I,NP1,IW)*WE(I,2*MP1-2,K)*WTS(I)
             END DO
          END DO
720  CONTINUE
      RETURN
!
!     case ityp=8   v odd, w even, and both br and bi equal zero
!
  800 CALL VBIN(1,NLAT,NLON,0,VB,IV,WVBIN)
!
!     case m=0
!
      DO  K = 1,NT
         DO  I = 1,IMID
            TW = WE(I,1,K)*WTS(I)
            DO  NP1 = 2,NDO2,2
               CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1,IV)*TW
            END DO
         END DO
      END DO
!
!     case m = 1 through nlat-1
!
      IF (MMAX.LT.2) RETURN
      DO 820 MP1 = 2,MMAX
          M = MP1 - 1
          MP2 = MP1 + 1
          CALL VBIN(1,NLAT,NLON,M,VB,IV,WVBIN)
          CALL WBIN(1,NLAT,NLON,M,WB,IW,WWBIN)
          IF (MP2.GT.NDO2) GO TO 820
          DO  K = 1,NT
             DO  I = 1,IMM1
                TWE1 = WE(I,2*MP1-1,K)*WTS(I)
                TWE2 = WE(I,2*MP1-2,K)*WTS(I)
                TVO1 = VO(I,2*MP1-1,K)*WTS(I)
                TVO2 = VO(I,2*MP1-2,K)*WTS(I)
                DO  NP1 = MP2,NDO2,2
                   CR(MP1,NP1,K) = CR(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE2 +  &
                        WB(I,NP1,IW)*TVO1A
                   CI(MP1,NP1,K) = CI(MP1,NP1,K) -      &
                        VB(I,NP1,IV)*TWE1 -  &
                        WB(I,NP1,IW)*TVO2
                END DO
             END DO
          END DO
          IF (MLAT.EQ.0) GO TO 820
          I = IMID
          DO  K = 1,NT
             DO  NP1 = MP2,NDO2,2
                CR(MP1,NP1,K) = CR(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-2,K)*WTS(I)
                CI(MP1,NP1,K) = CI(MP1,NP1,K) -  &
                     VB(I,NP1,IV)*WE(I,2*MP1-1,K)*WTS(I)
             END DO
          END DO
  820 CONTINUE
      RETURN
      END SUBROUTINE VHAGC1
