!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file vhags.f
!
!     this file contains code and documentation for subroutines
!     vhags and vhagsi
!
! ... files which must be loaded with vhags.f
!
!     sphcom.f, hrfft.f, gaqd.f
!
!     subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
!    +                 mdab,ndab,wvhags,lvhags,work,lwork,ierror)
!
!     subroutine vhags 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 vhses.
!
!     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 vhags,
!            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 the gaussian colatitude point theta(i)
!            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 vhags. 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 vhags. 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 vhags. 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 vhags. ndab must be at
!            least nlat.
!
!     wvhags an array which must be initialized by subroutine vhgsi.
!            once initialized, wvhags can be used repeatedly by vhags
!            as long as nlon and nlat remain unchanged.  wvhags must
!            not be altered between calls of vhags.
!
!     lvhags the dimension of the array wvhags as it appears in the
!            program that calls vhags. 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 lvhags must be at least
!
!            (nlat+1)*(nlat+1)*nlat/2 + nlon + 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 vhags. 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
!            the larger of the two quantities
!
!               3*nlat*(nlat+1)+2  (required by vhagsi)
!
!            and
!
!               (2*nt+1)*nlat*nlon
!
!            if ityp .gt. 2 then lwork must be at least
!            the larger of the two quantities
!
!               3*nlat*(nlat+1)+2  (required by vhagsi)
!
!            and
!
!              (2*nt+1)*l2*nlon
!
!
!     **************************************************************
!
!     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 vhses. 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 lvhags
!            = 10 error in the specification of lwork
!
!
!     subroutine vhagsi(nlat,nlon,wvhags,lvhags,work,lwork,ierror)
!
!     subroutine vhagsi initializes the array wvhags which can then be
!     used repeatedly by subroutine vhags 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.
!
!     lvhags the dimension of the array wvhags as it appears in the
!            program that calls vhagsi.  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 lvhags must be at least
!
!               3*nlat*(nlat+1)+2  (required by vhagsi)
!
!     dwork  a double precision work space that does not need to be saved
!
!     ldwork the dimension of the array dwork as it appears in the
!            program that calls vhagsi. ldwork must be at least
!
!                   (3*nlat*(nlat+3)+2)/2
!
!     **************************************************************
!
!     output parameters
!
!     wvhags an array which is initialized for use by subroutine vhags.
!            once initialized, wvhags can be used repeatedly by vhags
!            as long as nlat and nlon remain unchanged.  wvhags must not
!            be altered between calls of vhags.
!
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of lvhags
!            = 4  error in the specification of ldwork
!
      SUBROUTINE VHAGS(Nlat,Nlon,Ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,Cr,Ci,Mdab,&
                     & Ndab,Wvhags,Lvhags,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL Bi , Br , Ci , Cr , V , W , Work , Wvhags
      INTEGER idv , Idvw , idz , Ierror , imid , ist , Ityp , iw1 ,     &
            & iw2 , iw3 , iw4 , Jdvw , jw1 , jw2 , jw3 , lmn , lnl ,    &
            & Lvhags , Lwork , lzimn
      INTEGER 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) , Wvhags(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
      idz = (mmax*(Nlat+Nlat-mmax+1))/2
      lzimn = idz*imid
      IF ( Lvhags<lzimn+lzimn+Nlon+15 ) RETURN
      Ierror = 10
      idv = Nlat
      IF ( Ityp>2 ) idv = imid
      lnl = Nt*idv*Nlon
      IF ( Lwork<lnl+lnl+idv*Nlon ) RETURN
      Ierror = 0
      ist = 0
      IF ( Ityp<=2 ) ist = imid
!
!     set wvhags pointers
!
      lmn = Nlat*(Nlat+1)/2
      jw1 = 1
      jw2 = jw1 + imid*lmn
      jw3 = jw2 + imid*lmn
!
!     set work pointers
!
      iw1 = ist + 1
      iw2 = lnl + 1
      iw3 = iw2 + ist
      iw4 = iw2 + lnl
      CALL VHAGS1(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)&
                & ,idz,Wvhags(jw1),Wvhags(jw2),Wvhags(jw3))
    END SUBROUTINE VHAGS

      
    SUBROUTINE VHAGS1(Nlat,Nlon,Ityp,Nt,Imid,Idvw,Jdvw,V,W,Mdab,Ndab, &
                      & Br,Bi,Cr,Ci,Idv,Ve,Vo,We,Wo,Work,Idz,Vb,Wb,     &
                      & Wrfft)
      IMPLICIT NONE
      REAL Bi , Br , Ci , Cr , fsn , tsn , V , Vb , Ve , Vo , W , Wb ,  &
         & We , Wo , Work , Wrfft
      INTEGER i , Idv , Idvw , Idz , Imid , imm1 , Ityp , itypp , j ,   &
            & Jdvw , k , m , mb , Mdab , mlat , mlon , mmax , mp1 ,     &
            & mp2 , Ndab
      INTEGER ndo1 , ndo2 , Nlat , Nlon , nlp1 , np1 , 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) ,   &
              & Ve(Idv,Nlon,1) , Vo(Idv,Nlon,1) , We(Idv,Nlon,1) ,      &
              & Wo(Idv,Nlon,1) , Work(1) , Vb(Imid,1) , Wb(Imid,1) ,    &
              & Wrfft(1)
      nlp1 = Nlat + 1
      tsn = 2./Nlon
      fsn = 4./Nlon
      mlat = MOD(Nlat,2)
      mlon = MOD(Nlon,2)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      imm1 = Imid
      IF ( mlat/=0 ) imm1 = Imid - 1
      IF ( Ityp>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)
               ENDDO
            ENDDO
         ENDDO
      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))
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF ( mlat/=0 ) THEN
         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)
            ENDDO
         ENDDO
      ENDIF
      DO k = 1 , Nt
         CALL HRFFTF(Idv,Nlon,Ve(1,1,k),Idv,Wrfft,Work)
         CALL HRFFTF(Idv,Nlon,We(1,1,k),Idv,Wrfft,Work)
      ENDDO
      ndo1 = Nlat
      ndo2 = Nlat
      IF ( mlat/=0 ) ndo1 = Nlat - 1
      IF ( mlat==0 ) ndo2 = Nlat - 1
      IF ( Ityp/=2 .AND. Ityp/=5 .AND. Ityp/=8 ) THEN
         DO k = 1 , Nt
            DO mp1 = 1 , mmax
               DO np1 = mp1 , Nlat
                  Br(mp1,np1,k) = 0.
                  Bi(mp1,np1,k) = 0.
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF ( Ityp/=1 .AND. Ityp/=4 .AND. Ityp/=7 ) THEN
         DO k = 1 , Nt
            DO mp1 = 1 , mmax
               DO np1 = mp1 , Nlat
                  Cr(mp1,np1,k) = 0.
                  Ci(mp1,np1,k) = 0.
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      itypp = Ityp + 1
      IF ( itypp==2 ) THEN
!
!     case ityp=1 ,  no symmetries but cr and ci equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==3 ) THEN
!
!     case ityp=2 ,  no symmetries but br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==4 ) THEN
!
!     case ityp=3 ,  v even , w odd
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==5 ) THEN
!
!     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==6 ) THEN
!
!     case ityp=5   v even, w odd, and br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==7 ) THEN
!
!     case ityp=6 ,  v odd , w even
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==8 ) THEN
!
!     case ityp=7   v odd, w even, and cr and ci equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==9 ) THEN
!
!     case ityp=8   v odd, w even, and both br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         GOTO 99999
      ENDIF
!
!     case ityp=0 ,  no symmetries
!
!     case m=0
!
      DO k = 1 , Nt
         DO i = 1 , Imid
            DO np1 = 2 , ndo2 , 2
               Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
            ENDDO
         ENDDO
      ENDDO
      DO k = 1 , Nt
         DO i = 1 , imm1
            DO np1 = 3 , ndo1 , 2
               Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
            ENDDO
         ENDDO
      ENDDO
!
!     case m = 1 through nlat-1
!
      IF ( mmax<2 ) RETURN
      DO mp1 = 2 , mmax
         m = mp1 - 1
         mb = m*Nlat - (m*(m+1))/2
         mp2 = mp1 + 1
         IF ( mp1<=ndo1 ) THEN
            DO k = 1 , Nt
               DO i = 1 , imm1
                  DO np1 = mp1 , ndo1 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *We(i,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *We(i,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Ve(i,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Ve(i,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDDO
            IF ( mlat/=0 ) THEN
               DO k = 1 , Nt
                  DO np1 = mp1 , ndo1 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
         IF ( mp2<=ndo2 ) THEN
            DO k = 1 , Nt
               DO i = 1 , imm1
                  DO np1 = mp2 , ndo2 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Wo(i,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Wo(i,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *We(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Vo(i,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *We(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Vo(i,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDDO
            IF ( mlat/=0 ) THEN
               DO k = 1 , Nt
                  DO np1 = mp2 , ndo2 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-2,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-1,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-2,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-1,k)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      RETURN
99999 END SUBROUTINE VHAGS1


      SUBROUTINE VHAGSI(Nlat,Nlon,Wvhags,Lvhags,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , iw2 , iw3 , iw4 , jw1 , jw2 , jw3 , &
            & Ldwork , lmn , Lvhags , Nlat , Nlon
      REAL, DIMENSION(Lvhags) :: Wvhags
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      imid = (Nlat+1)/2
      lmn = (Nlat*(Nlat+1))/2
      IF ( Lvhags<2*(imid*lmn)+Nlon+15 ) RETURN
      Ierror = 4
!     if (ldwork.lt.nlat*(3*nlat+9)+2) return
      IF ( Ldwork<(Nlat*(3*Nlat+9)+2)/2 ) RETURN
      Ierror = 0
      jw1 = 1
      jw2 = jw1 + imid*lmn
      jw3 = jw2 + imid*lmn
      iw1 = 1
      iw2 = iw1 + Nlat
      iw3 = iw2 + Nlat
      iw4 = iw3 + 3*imid*Nlat
!     iw2 = iw1+nlat+nlat
!     iw3 = iw2+nlat+nlat
!     iw4 = iw3+6*imid*nlat
      CALL VHGAI1(Nlat,imid,Wvhags(jw1),Wvhags(jw2),Dwork(iw1),         &
                & Dwork(iw2),Dwork(iw3),Dwork(iw4))
      CALL HRFFTI(Nlon,Wvhags(jw3))
    END SUBROUTINE VHAGSI


    SUBROUTINE VHGAI1(Nlat,Imid,Vb,Wb,Dthet,Dwts,Dpbar,Work)
      IMPLICIT NONE
      INTEGER i , id , ierror , Imid , INDX , ix , iy , lwk , m , mn ,  &
            & n , Nlat , nm , np , nz
      REAL Vb , Wb
      DIMENSION Vb(Imid,*) , Wb(Imid,*)
      DOUBLE PRECISION abel , bbel , cbel , ssqr2 , dcf
      DOUBLE PRECISION Dpbar(Imid,Nlat,3) , Dthet(*) , Dwts(*) , Work(*)
!     lwk = 4*nlat*(nlat+2)
      lwk = Nlat*(Nlat+2)
      CALL GAQD(Nlat,Dthet,Dwts,Dpbar,lwk,ierror)
!
!     compute associated legendre functions
!
!     compute m=n=0 legendre polynomials for all theta(i)
!
      ssqr2 = 1./DSQRT(2.D0)
      DO i = 1 , Imid
         Dpbar(i,1,1) = ssqr2
         Vb(i,1) = 0.
         Wb(i,1) = 0.
      ENDDO
!
!     main loop for remaining vb, and wb
!
      DO n = 1 , Nlat - 1
         nm = MOD(n-2,3) + 1
         nz = MOD(n-1,3) + 1
         np = MOD(n,3) + 1
!
!     compute dpbar for m=0
!
         CALL DNLFK(0,n,Work)
         mn = INDX(0,n,Nlat)
         DO i = 1 , Imid
            CALL DNLFT(0,n,Dthet(i),Work,Dpbar(i,1,np))
         ENDDO
!
!     compute dpbar for m=1
!
         CALL DNLFK(1,n,Work)
         mn = INDX(1,n,Nlat)
         DO i = 1 , Imid
            CALL DNLFT(1,n,Dthet(i),Work,Dpbar(i,2,np))
!      pbar(i,mn) = dpbar(i,2,np)
         ENDDO
!
!     compute and store dpbar for m=2,n
!
         IF ( n>=2 ) THEN
            DO m = 2 , n
               abel = DSQRT(DBLE(FLOAT((2*n+1)*(m+n-2)*(m+n-3)))        &
                    & /DBLE(FLOAT((2*n-3)*(m+n-1)*(m+n))))
               bbel = DSQRT(DBLE(FLOAT((2*n+1)*(n-m-1)*(n-m)))          &
                    & /DBLE(FLOAT((2*n-3)*(m+n-1)*(m+n))))
               cbel = DSQRT(DBLE(FLOAT((n-m+1)*(n-m+2)))                &
                    & /DBLE(FLOAT((m+n-1)*(m+n))))
               id = INDX(m,n,Nlat)
               IF ( m>=n-1 ) THEN
                  DO i = 1 , Imid
                     Dpbar(i,m+1,np) = abel*Dpbar(i,m-1,nm)             &
                                     & - cbel*Dpbar(i,m-1,np)
                  ENDDO
               ELSE
                  DO i = 1 , Imid
                     Dpbar(i,m+1,np) = abel*Dpbar(i,m-1,nm)             &
                                     & + bbel*Dpbar(i,m+1,nm)           &
                                     & - cbel*Dpbar(i,m-1,np)
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
!
!     compute the derivative of the functions
!
         ix = INDX(0,n,Nlat)
         iy = INDX(n,n,Nlat)
         DO i = 1 , Imid
            Vb(i,ix) = -Dpbar(i,2,np)*Dwts(i)
            Vb(i,iy) = Dpbar(i,n,np)/DSQRT(DBLE(FLOAT(2*(n+1))))*Dwts(i)
         ENDDO
!
         IF ( n/=1 ) THEN
            dcf = DSQRT(DBLE(FLOAT(4*n*(n+1))))
            DO m = 1 , n - 1
               ix = INDX(m,n,Nlat)
               abel = DSQRT(DBLE(FLOAT((n+m)*(n-m+1))))/dcf
               bbel = DSQRT(DBLE(FLOAT((n-m)*(n+m+1))))/dcf
               DO i = 1 , Imid
                  Vb(i,ix) = (abel*Dpbar(i,m,np)-bbel*Dpbar(i,m+2,np))  &
                           & *Dwts(i)
               ENDDO
            ENDDO
         ENDIF
!
!     compute the vector harmonic w(theta) = m*pbar/cos(theta)
!
!     set wb=0 for m=0
!
         ix = INDX(0,n,Nlat)
         DO i = 1 , Imid
            Wb(i,ix) = 0.D0
         ENDDO
!
!     compute wb for m=1,n
!
         dcf = DSQRT(DBLE(FLOAT(n+n+1))/DBLE(FLOAT(4*n*(n+1)*(n+n-1))))
         DO m = 1 , n
            ix = INDX(m,n,Nlat)
            abel = dcf*DSQRT(DBLE(FLOAT((n+m)*(n+m-1))))
            bbel = dcf*DSQRT(DBLE(FLOAT((n-m)*(n-m-1))))
            IF ( m>=n-1 ) THEN
               DO i = 1 , Imid
                  Wb(i,ix) = abel*Dpbar(i,m,nz)*Dwts(i)
               ENDDO
            ELSE
               DO i = 1 , Imid
                  Wb(i,ix) = (abel*Dpbar(i,m,nz)+bbel*Dpbar(i,m+2,nz))  &
                           & *Dwts(i)
               ENDDO
            ENDIF
         ENDDO
      ENDDO
      END SUBROUTINE VHGAI1

      
      FUNCTION INDX(M,N,Nlat)
      IMPLICIT NONE
      INTEGER M , N , Nlat
      INTEGER INDX
      INDX = M*Nlat - (M*(M+1))/2 + N + 1
      END FUNCTION INDX


      SUBROUTINE DVHAGS(Nlat,Nlon,Ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,Cr,Ci,Mdab,&
                     & Ndab,Wvhags,Lvhags,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION Bi , Br , Ci , Cr , V , W , Work , Wvhags
      INTEGER idv , Idvw , idz , Ierror , imid , ist , Ityp , iw1 ,     &
            & iw2 , iw3 , iw4 , Jdvw , jw1 , jw2 , jw3 , lmn , lnl ,    &
            & Lvhags , Lwork , lzimn
      INTEGER 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) , Wvhags(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
      idz = (mmax*(Nlat+Nlat-mmax+1))/2
      lzimn = idz*imid
      IF ( Lvhags<lzimn+lzimn+Nlon+15 ) RETURN
      Ierror = 10
      idv = Nlat
      IF ( Ityp>2 ) idv = imid
      lnl = Nt*idv*Nlon
      IF ( Lwork<lnl+lnl+idv*Nlon ) RETURN
      Ierror = 0
      ist = 0
      IF ( Ityp<=2 ) ist = imid
!
!     set wvhags pointers
!
      lmn = Nlat*(Nlat+1)/2
      jw1 = 1
      jw2 = jw1 + imid*lmn
      jw3 = jw2 + imid*lmn
!
!     set work pointers
!
      iw1 = ist + 1
      iw2 = lnl + 1
      iw3 = iw2 + ist
      iw4 = iw2 + lnl
      CALL DVHAGS1(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)&
                & ,idz,Wvhags(jw1),Wvhags(jw2),Wvhags(jw3))
    END SUBROUTINE DVHAGS

      
    SUBROUTINE DVHAGS1(Nlat,Nlon,Ityp,Nt,Imid,Idvw,Jdvw,V,W,Mdab,Ndab, &
                      & Br,Bi,Cr,Ci,Idv,Ve,Vo,We,Wo,Work,Idz,Vb,Wb,     &
                      & Wrfft)
      IMPLICIT NONE
      DOUBLE PRECISION Bi , Br , Ci , Cr , fsn , tsn , V , Vb , Ve , Vo , W , Wb ,  &
         & We , Wo , Work , Wrfft
      INTEGER i , Idv , Idvw , Idz , Imid , imm1 , Ityp , itypp , j ,   &
            & Jdvw , k , m , mb , Mdab , mlat , mlon , mmax , mp1 ,     &
            & mp2 , Ndab
      INTEGER ndo1 , ndo2 , Nlat , Nlon , nlp1 , np1 , 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) ,   &
              & Ve(Idv,Nlon,1) , Vo(Idv,Nlon,1) , We(Idv,Nlon,1) ,      &
              & Wo(Idv,Nlon,1) , Work(1) , Vb(Imid,1) , Wb(Imid,1) ,    &
              & Wrfft(1)
      nlp1 = Nlat + 1
      tsn = 2./Nlon
      fsn = 4./Nlon
      mlat = MOD(Nlat,2)
      mlon = MOD(Nlon,2)
      mmax = MIN0(Nlat,(Nlon+1)/2)
      imm1 = Imid
      IF ( mlat/=0 ) imm1 = Imid - 1
      IF ( Ityp>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)
               ENDDO
            ENDDO
         ENDDO
      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))
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF ( mlat/=0 ) THEN
         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)
            ENDDO
         ENDDO
      ENDIF
      DO k = 1 , Nt
         CALL DHRFFTF(Idv,Nlon,Ve(1,1,k),Idv,Wrfft,Work)
         CALL DHRFFTF(Idv,Nlon,We(1,1,k),Idv,Wrfft,Work)
      ENDDO
      ndo1 = Nlat
      ndo2 = Nlat
      IF ( mlat/=0 ) ndo1 = Nlat - 1
      IF ( mlat==0 ) ndo2 = Nlat - 1
      IF ( Ityp/=2 .AND. Ityp/=5 .AND. Ityp/=8 ) THEN
         DO k = 1 , Nt
            DO mp1 = 1 , mmax
               DO np1 = mp1 , Nlat
                  Br(mp1,np1,k) = 0.
                  Bi(mp1,np1,k) = 0.
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      IF ( Ityp/=1 .AND. Ityp/=4 .AND. Ityp/=7 ) THEN
         DO k = 1 , Nt
            DO mp1 = 1 , mmax
               DO np1 = mp1 , Nlat
                  Cr(mp1,np1,k) = 0.
                  Ci(mp1,np1,k) = 0.
               ENDDO
            ENDDO
         ENDDO
      ENDIF
      itypp = Ityp + 1
      IF ( itypp==2 ) THEN
!
!     case ityp=1 ,  no symmetries but cr and ci equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==3 ) THEN
!
!     case ityp=2 ,  no symmetries but br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==4 ) THEN
!
!     case ityp=3 ,  v even , w odd
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==5 ) THEN
!
!     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Wo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==6 ) THEN
!
!     case ityp=5   v even, w odd, and br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Ve(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *Ve(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==7 ) THEN
!
!     case ityp=6 ,  v odd , w even
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==8 ) THEN
!
!     case ityp=7   v odd, w even, and cr and ci equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , imm1
               DO np1 = 3 , ndo1 , 2
                  Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp1<=ndo1 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *We(i,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)    &
                                      & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *We(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp1 , ndo1 , 2
                        Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                        Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         RETURN
      ELSEIF ( itypp==9 ) THEN
!
!     case ityp=8   v odd, w even, and both br and bi equal zero
!
!     case m=0
!
         DO k = 1 , Nt
            DO i = 1 , Imid
               DO np1 = 2 , ndo2 , 2
                  Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
               ENDDO
            ENDDO
         ENDDO
!
!     case m = 1 through nlat-1
!
         IF ( mmax<2 ) RETURN
         DO mp1 = 2 , mmax
            m = mp1 - 1
            mb = m*Nlat - (m*(m+1))/2
            mp2 = mp1 + 1
            IF ( mp2<=ndo2 ) THEN
               DO k = 1 , Nt
                  DO i = 1 , imm1
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-2,k) + Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-1,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)    &
                                      & *We(i,2*mp1-1,k) - Wb(i,np1+mb) &
                                      & *Vo(i,2*mp1-2,k)
                     ENDDO
                  ENDDO
               ENDDO
               IF ( mlat/=0 ) THEN
                  DO k = 1 , Nt
                     DO np1 = mp2 , ndo2 , 2
                        Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-2,k)
                        Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb) &
                                      & *We(Imid,2*mp1-1,k)
                     ENDDO
                  ENDDO
               ENDIF
            ENDIF
         ENDDO
         GOTO 99999
      ENDIF
!
!     case ityp=0 ,  no symmetries
!
!     case m=0
!
      DO k = 1 , Nt
         DO i = 1 , Imid
            DO np1 = 2 , ndo2 , 2
               Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Ve(i,1,k)
               Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*We(i,1,k)
            ENDDO
         ENDDO
      ENDDO
      DO k = 1 , Nt
         DO i = 1 , imm1
            DO np1 = 3 , ndo1 , 2
               Br(1,np1,k) = Br(1,np1,k) + Vb(i,np1)*Vo(i,1,k)
               Cr(1,np1,k) = Cr(1,np1,k) - Vb(i,np1)*Wo(i,1,k)
            ENDDO
         ENDDO
      ENDDO
!
!     case m = 1 through nlat-1
!
      IF ( mmax<2 ) RETURN
      DO mp1 = 2 , mmax
         m = mp1 - 1
         mb = m*Nlat - (m*(m+1))/2
         mp2 = mp1 + 1
         IF ( mp1<=ndo1 ) THEN
            DO k = 1 , Nt
               DO i = 1 , imm1
                  DO np1 = mp1 , ndo1 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Vo(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *We(i,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Vo(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *We(i,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *Wo(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Ve(i,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *Wo(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Ve(i,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDDO
            IF ( mlat/=0 ) THEN
               DO k = 1 , Nt
                  DO np1 = mp1 , ndo1 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Wb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) - Wb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) + Wb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Wb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
         IF ( mp2<=ndo2 ) THEN
            DO k = 1 , Nt
               DO i = 1 , imm1
                  DO np1 = mp2 , ndo2 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Ve(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Wo(i,2*mp1-1,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(i,np1+mb)       &
                                   & *Ve(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Wo(i,2*mp1-2,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *We(i,2*mp1-2,k) + Wb(i,np1+mb)    &
                                   & *Vo(i,2*mp1-1,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(i,np1+mb)       &
                                   & *We(i,2*mp1-1,k) - Wb(i,np1+mb)    &
                                   & *Vo(i,2*mp1-2,k)
                  ENDDO
               ENDDO
            ENDDO
            IF ( mlat/=0 ) THEN
               DO k = 1 , Nt
                  DO np1 = mp2 , ndo2 , 2
                     Br(mp1,np1,k) = Br(mp1,np1,k) + Vb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-2,k)
                     Bi(mp1,np1,k) = Bi(mp1,np1,k) + Vb(Imid,np1+mb)    &
                                   & *Ve(Imid,2*mp1-1,k)
                     Cr(mp1,np1,k) = Cr(mp1,np1,k) - Vb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-2,k)
                     Ci(mp1,np1,k) = Ci(mp1,np1,k) - Vb(Imid,np1+mb)    &
                                   & *We(Imid,2*mp1-1,k)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
      ENDDO
      RETURN
99999 END SUBROUTINE DVHAGS1


      SUBROUTINE DVHAGSI(Nlat,Nlon,Wvhags,Lvhags,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER Ierror , imid , iw1 , iw2 , iw3 , iw4 , jw1 , jw2 , jw3 , &
            & Ldwork , lmn , Lvhags , Nlat , Nlon
      DOUBLE PRECISION, DIMENSION(Lvhags) :: Wvhags
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<1 ) RETURN
      Ierror = 3
      imid = (Nlat+1)/2
      lmn = (Nlat*(Nlat+1))/2
      IF ( Lvhags<2*(imid*lmn)+Nlon+15 ) RETURN
      Ierror = 4
!     if (ldwork.lt.nlat*(3*nlat+9)+2) return
      IF ( Ldwork<(Nlat*(3*Nlat+9)+2)/2 ) RETURN
      Ierror = 0
      jw1 = 1
      jw2 = jw1 + imid*lmn
      jw3 = jw2 + imid*lmn
      iw1 = 1
      iw2 = iw1 + Nlat
      iw3 = iw2 + Nlat
      iw4 = iw3 + 3*imid*Nlat
!     iw2 = iw1+nlat+nlat
!     iw3 = iw2+nlat+nlat
!     iw4 = iw3+6*imid*nlat
      CALL DVHGAI1(Nlat,imid,Wvhags(jw1),Wvhags(jw2),Dwork(iw1),         &
                & Dwork(iw2),Dwork(iw3),Dwork(iw4))
      CALL DHRFFTI(Nlon,Wvhags(jw3))
    END SUBROUTINE DVHAGSI


    SUBROUTINE DVHGAI1(Nlat,Imid,Vb,Wb,Dthet,Dwts,Dpbar,Work)
      IMPLICIT NONE
      INTEGER i , id , ierror , Imid , INDX , ix , iy , lwk , m , mn ,  &
            & n , Nlat , nm , np , nz
      DOUBLE PRECISION Vb , Wb
      DIMENSION Vb(Imid,*) , Wb(Imid,*)
      DOUBLE PRECISION abel , bbel , cbel , ssqr2 , dcf
      DOUBLE PRECISION Dpbar(Imid,Nlat,3) , Dthet(*) , Dwts(*) , Work(*)
!     lwk = 4*nlat*(nlat+2)
      lwk = Nlat*(Nlat+2)
      CALL DGAQD(Nlat,Dthet,Dwts,Dpbar,lwk,ierror)
!
!     compute associated legendre functions
!
!     compute m=n=0 legendre polynomials for all theta(i)
!
      ssqr2 = 1./DSQRT(2.D0)
      DO i = 1 , Imid
         Dpbar(i,1,1) = ssqr2
         Vb(i,1) = 0.
         Wb(i,1) = 0.
      ENDDO
!
!     main loop for remaining vb, and wb
!
      DO n = 1 , Nlat - 1
         nm = MOD(n-2,3) + 1
         nz = MOD(n-1,3) + 1
         np = MOD(n,3) + 1
!
!     compute dpbar for m=0
!
         CALL DDNLFK(0,n,Work)
         mn = INDX(0,n,Nlat)
         DO i = 1 , Imid
            CALL DDNLFT(0,n,Dthet(i),Work,Dpbar(i,1,np))
         ENDDO
!
!     compute dpbar for m=1
!
         CALL DDNLFK(1,n,Work)
         mn = INDX(1,n,Nlat)
         DO i = 1 , Imid
            CALL DDNLFT(1,n,Dthet(i),Work,Dpbar(i,2,np))
!      pbar(i,mn) = dpbar(i,2,np)
         ENDDO
!
!     compute and store dpbar for m=2,n
!
         IF ( n>=2 ) THEN
            DO m = 2 , n
               abel = DSQRT(DBLE(FLOAT((2*n+1)*(m+n-2)*(m+n-3)))        &
                    & /DBLE(FLOAT((2*n-3)*(m+n-1)*(m+n))))
               bbel = DSQRT(DBLE(FLOAT((2*n+1)*(n-m-1)*(n-m)))          &
                    & /DBLE(FLOAT((2*n-3)*(m+n-1)*(m+n))))
               cbel = DSQRT(DBLE(FLOAT((n-m+1)*(n-m+2)))                &
                    & /DBLE(FLOAT((m+n-1)*(m+n))))
               id = INDX(m,n,Nlat)
               IF ( m>=n-1 ) THEN
                  DO i = 1 , Imid
                     Dpbar(i,m+1,np) = abel*Dpbar(i,m-1,nm)             &
                                     & - cbel*Dpbar(i,m-1,np)
                  ENDDO
               ELSE
                  DO i = 1 , Imid
                     Dpbar(i,m+1,np) = abel*Dpbar(i,m-1,nm)             &
                                     & + bbel*Dpbar(i,m+1,nm)           &
                                     & - cbel*Dpbar(i,m-1,np)
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
!
!     compute the derivative of the functions
!
         ix = INDX(0,n,Nlat)
         iy = INDX(n,n,Nlat)
         DO i = 1 , Imid
            Vb(i,ix) = -Dpbar(i,2,np)*Dwts(i)
            Vb(i,iy) = Dpbar(i,n,np)/DSQRT(DBLE(FLOAT(2*(n+1))))*Dwts(i)
         ENDDO
!
         IF ( n/=1 ) THEN
            dcf = DSQRT(DBLE(FLOAT(4*n*(n+1))))
            DO m = 1 , n - 1
               ix = INDX(m,n,Nlat)
               abel = DSQRT(DBLE(FLOAT((n+m)*(n-m+1))))/dcf
               bbel = DSQRT(DBLE(FLOAT((n-m)*(n+m+1))))/dcf
               DO i = 1 , Imid
                  Vb(i,ix) = (abel*Dpbar(i,m,np)-bbel*Dpbar(i,m+2,np))  &
                           & *Dwts(i)
               ENDDO
            ENDDO
         ENDIF
!
!     compute the vector harmonic w(theta) = m*pbar/cos(theta)
!
!     set wb=0 for m=0
!
         ix = INDX(0,n,Nlat)
         DO i = 1 , Imid
            Wb(i,ix) = 0.D0
         ENDDO
!
!     compute wb for m=1,n
!
         dcf = DSQRT(DBLE(FLOAT(n+n+1))/DBLE(FLOAT(4*n*(n+1)*(n+n-1))))
         DO m = 1 , n
            ix = INDX(m,n,Nlat)
            abel = dcf*DSQRT(DBLE(FLOAT((n+m)*(n+m-1))))
            bbel = dcf*DSQRT(DBLE(FLOAT((n-m)*(n-m-1))))
            IF ( m>=n-1 ) THEN
               DO i = 1 , Imid
                  Wb(i,ix) = abel*Dpbar(i,m,nz)*Dwts(i)
               ENDDO
            ELSE
               DO i = 1 , Imid
                  Wb(i,ix) = (abel*Dpbar(i,m,nz)+bbel*Dpbar(i,m+2,nz))  &
                           & *Dwts(i)
               ENDDO
            ENDIF
         ENDDO
      ENDDO
      END SUBROUTINE DVHGAI1

