c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhagc.f
c
c     this file contains code and documentation for subroutines
c     vhagc and vhagci
c
c ... files which must be loaded with vhagc.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c
c     subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhagc,lvhagc,work,lwork,ierror)
c
c     subroutine vhagc performs the vector spherical harmonic analysis
c     on the vector field (v,w) and stores the result in the arrays
c     br,bi,cr, and ci. v(i,j) and w(i,j) are the colatitudinal
c     (measured from the north pole) and east longitudinal components
c     respectively, located at the gaussian colatitude point theta(i)
c     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
c     representation of (v,w) is given at output parameters v,w in
c     subroutine vhsec.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of analyses.  in the program that calls vhagc,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple analyses will be performed.
c            the third index is the analysis index which assumes the
c            values k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            that contain the vector function to be analyzed.
c            v is the colatitudnal component and w is the east
c            longitudinal component. v(i,j),w(i,j) contain the
c            components at colatitude theta(i) = (i-1)*pi/(nlat-1)
c            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
c            are defined above at the input parameter ityp.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhagc. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhagc. jdvw must be at least nlon.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhagc. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhagc. ndab must be at
c            least nlat.
c
c     wvhagc an array which must be initialized by subroutine vhagci.
c            once initialized, wvhagc can be used repeatedly by vhagc
c            as long as nlon and nlat remain unchanged.  wvhagc must
c            not be altered between calls of vhagc.
c
c     lvhagc the dimension of the array wvhagc as it appears in the
c            program that calls vhagc. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhagc must be at least
c
c               4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhagc. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c
c               2*nlat*(2*nlon*nt+3*l2)
c
c            if ityp .gt. 2 then lwork must be at least
c
c               2*l2*(2*nlon*nt+3*nlat)
c
c
c
c     **************************************************************
c
c     output parameters
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            in the discription of subroutine vhsec. br(mp1,np1),
c            bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed
c            for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat
c            and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or
c            mmax=min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhagc
c            = 10 error in the specification of lwork
c
c ****************************************************************
c
c     subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror)
c
c     subroutine vhagci initializes the array wvhagc which can then be
c     used repeatedly by subroutine vhagc until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhagc the dimension of the array wvhagc as it appears in the
c            program that calls vhagci.  define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhagc must be at least
c
c               4*nlat*l2+3*max0(l1-2,0)*(2*nlat-l1-1)+nlon+l2+15
c
c
c     dwork  a double precision work array that does not need to be saved
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhagci. ldwork must be at least
c
c               2*nlat*(nlat+1)+1
c
c
c     **************************************************************
c
c     output parameters
c
c     wvhagc an array which is initialized for use by subroutine vhagc.
c            once initialized, wvhagc can be used repeatedly by vhagc
c            as long as nlat and nlon remain unchanged.  wvhagc must not
c            be altered between calls of vhagc.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhagc
c            = 4  error in the specification of lwork
c
      subroutine vhagc(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
     1           mdab,ndab,wvhagc,lvhagc,work,lwork,ierror)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          work(1),wvhagc(1)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 1) return
      ierror = 3
      if(ityp.lt.0 .or. ityp.gt.8) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((ityp.le.2 .and. idvw.lt.nlat) .or.
     +   (ityp.gt.2 .and. idvw.lt.imid)) return
      ierror = 6
      if(jdvw .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+1)/2)
      if(mdab .lt. mmax) return
      ierror = 8
      if(ndab .lt. nlat) return
      ierror = 9
      lzz1 = 2*nlat*imid
      labc = 3*(max0(mmax-2,0)*(nlat+nlat-mmax-1))/2
      if(lvhagc .lt. 2*(lzz1+labc)+nlon+imid+15) return
      ierror = 10
      if (ityp.le.2 .and. lwork.lt.nlat*(4*nlon*nt+6*imid)) return
      if (ityp.gt.2 .and. lwork.lt.imid*(4*nlon*nt+6*nlat)) return
      ierror = 0
      idv = nlat
      if(ityp .gt. 2) idv = imid
      lnl = nt*idv*nlon
      ist = 0
      if(ityp .le. 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))
      return
      end
      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)
      dimension v(idvw,jdvw,1),w(idvw,jdvw,1),br(mdab,ndab,1),
     1          bi(mdab,ndab,1),cr(mdab,ndab,1),ci(mdab,ndab,1),
     2          ve(idv,nlon,1),vo(idv,nlon,1),we(idv,nlon,1),
     3          wo(idv,nlon,1),wts(*),wvbin(1),wwbin(1),wrfft(1),
     4          vb(imid,nlat,3),wb(imid,nlat,3)
      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 .ne. 0) imm1 = imid-1
      if(ityp .gt. 2) go to 3
      do 5 k=1,nt
      do 5 i=1,imm1
      do 5 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))
    5 continue
      go to 2
    3 do 8 k=1,nt
      do 8 i=1,imm1
      do 8 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)
    8 continue
    2 if(mlat .eq. 0) go to 7
      do 6 k=1,nt
      do 6 j=1,nlon
      ve(imid,j,k) = tsn*v(imid,j,k)
      we(imid,j,k) = tsn*w(imid,j,k)
    6 continue
    7 do 9 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)
    9 continue
      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 10 k=1,nt
      do 10 mp1=1,mmax
      do 10 np1=mp1,nlat
      br(mp1,np1,k)=0.
      bi(mp1,np1,k)=0.
   10 continue
   11 if(ityp.eq.1 .or. ityp.eq.4 .or. ityp.eq.7) go to 13
      do 12 k=1,nt
      do 12 mp1=1,mmax
      do 12 np1=mp1,nlat
      cr(mp1,np1,k)=0.
      ci(mp1,np1,k)=0.
   12 continue
   13 itypp = ityp+1
      go to (1,100,200,300,400,500,600,700,800),itypp
c
c     case ityp=0 ,  no symmetries
c
    1 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 15 k=1,nt
      do 1015 i=1,imid
      tv = ve(i,1,k)*wts(i)
      tw = we(i,1,k)*wts(i)
      do 10015 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
10015 continue
 1015 continue
   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
c
c     case m = 1 through nlat-1
c
      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 23 k=1,nt
      do 1023 i=1,imm1
c
c     set temps to optimize quadrature
c
      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 10023 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
10023 continue
 1023 continue
   23 continue

      if(mlat .eq. 0) go to 17
      i = imid
      do 24 k=1,nt
      do 1024 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)
 1024 continue
   24 continue
   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
     1                             +wb(i,np1,iw)*two1
      bi(mp1,np1,k) = bi(mp1,np1,k)+vb(i,np1,iv)*tve1
     1                             -wb(i,np1,iw)*two2
      cr(mp1,np1,k) = cr(mp1,np1,k)-vb(i,np1,iv)*twe2
     1                             +wb(i,np1,iw)*tvo1
      ci(mp1,np1,k) = ci(mp1,np1,k)-vb(i,np1,iv)*twe1
     1                             -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
c
c     case ityp=1 ,  no symmetries but cr and ci equal zero
c
  100 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 115 k=1,nt
      do 115 i=1,imid
      tv = ve(i,1,k)*wts(i)
      do 115 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  115 continue
      do 116 k=1,nt
      do 116 i=1,imm1
      tv = vo(i,1,k)*wts(i)
      do 116 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  116 continue
c
c     case m = 1 through nlat-1
c
      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 123 k=1,nt
      do 123 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 123 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
  123 continue
      if(mlat .eq. 0) go to 117
      i = imid
      do 124 k=1,nt
      do 124 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)
  124 continue
  117 if(mp2 .gt. ndo2) go to 120
      do 121 k=1,nt
      do 121 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 121 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
  121 continue
      if(mlat .eq. 0) go to 120
      i = imid
      do 122 k=1,nt
      do 122 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)
  122 continue
  120 continue
      return
c
c     case ityp=2 ,  no symmetries but br and bi equal zero
c
  200 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 215 k=1,nt
      do 215 i=1,imid
      tw = we(i,1,k)*wts(i)
      do 215 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  215 continue
      do 216 k=1,nt
      do 216 i=1,imm1
      tw = wo(i,1,k)*wts(i)
      do 216 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  216 continue
c
c     case m = 1 through nlat-1
c
      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 223 k=1,nt
      do 223 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 223 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
  223 continue
      if(mlat .eq. 0) go to 217
      i = imid
      do 224 k=1,nt
      do 224 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)
  224 continue
  217 if(mp2 .gt. ndo2) go to 220
      do 221 k=1,nt
      do 221 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 221 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
  221 continue
      if(mlat .eq. 0) go to 220
      i = imid
      do 222 k=1,nt
      do 222 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)
  222 continue
  220 continue
      return
c
c     case ityp=3 ,  v even , w odd
c
  300 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 315 k=1,nt
      do 315 i=1,imid
      tv = ve(i,1,k)*wts(i)
      do 315 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  315 continue
      do 316 k=1,nt
      do 316 i=1,imm1
      tw = wo(i,1,k)*wts(i)
      do 316 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  316 continue
c
c     case m = 1 through nlat-1
c
      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 323 k=1,nt
      do 323 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 323 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
  323 continue
      if(mlat .eq. 0) go to 317
      i = imid
      do 324 k=1,nt
      do 324 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)
  324 continue
  317 if(mp2 .gt. ndo2) go to 320
      do 321 k=1,nt
      do 321 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 321 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
  321 continue
      if(mlat .eq. 0) go to 320
      i = imid
      do 322 k=1,nt
      do 322 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)
  322 continue
  320 continue
      return
c
c     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
c
  400 call vbin(1,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 415 k=1,nt
      do 415 i=1,imid
      tv = ve(i,1,k)*wts(i)
      do 415 np1=2,ndo2,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  415 continue
c
c     case m = 1 through nlat-1
c
      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 421 k=1,nt
      do 421 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 421 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
  421 continue
      if(mlat .eq. 0) go to 420
      i = imid
      do 422 k=1,nt
      do 422 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)
  422 continue
  420 continue
      return
c
c     case ityp=5   v even, w odd, and br and bi equal zero
c
  500 call vbin(2,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 516 k=1,nt
      do 516 i=1,imm1
      tw = wo(i,1,k)*wts(i)
      do 516 np1=3,ndo1,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  516 continue
c
c     case m = 1 through nlat-1
c
      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 523 k=1,nt
      do 523 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 523 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
  523 continue
      if(mlat .eq. 0) go to 520
      i = imid
      do 524 k=1,nt
      do 524 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)
  524 continue
  520 continue
      return
c
c     case ityp=6 ,  v odd , w even
c
  600 call vbin(0,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 615 k=1,nt
      do 615 i=1,imid
      tw = we(i,1,k)*wts(i)
      do 615 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  615 continue
      do 616 k=1,nt
      do 616 i=1,imm1
      tv = vo(i,1,k)*wts(i)
      do 616 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  616 continue
c
c     case m = 1 through nlat-1
c
      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 623 k=1,nt
      do 623 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 623 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
  623 continue
      if(mlat .eq. 0) go to 617
      i = imid
      do 624 k=1,nt
      do 624 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)
  624 continue
  617 if(mp2 .gt. ndo2) go to 620
      do 621 k=1,nt
      do 621 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 621 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
  621 continue
      if(mlat .eq. 0) go to 620
      i = imid
      do 622 k=1,nt
      do 622 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)
  622 continue
  620 continue
      return
c
c     case ityp=7   v odd, w even, and cr and ci equal zero
c
  700 call vbin(2,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 716 k=1,nt
      do 716 i=1,imm1
      tv = vo(i,1,k)*wts(i)
      do 716 np1=3,ndo1,2
      br(1,np1,k) = br(1,np1,k)+vb(i,np1,iv)*tv
  716 continue
c
c     case m = 1 through nlat-1
c
      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 723 k=1,nt
      do 723 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 723 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
  723 continue
      if(mlat .eq. 0) go to 720
      i = imid
      do 724 k=1,nt
      do 724 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)
  724 continue
  720 continue
      return
c
c     case ityp=8   v odd, w even, and both br and bi equal zero
c
  800 call vbin(1,nlat,nlon,0,vb,iv,wvbin)
c
c     case m=0
c
      do 815 k=1,nt
      do 815 i=1,imid
      tw = we(i,1,k)*wts(i)
      do 815 np1=2,ndo2,2
      cr(1,np1,k) = cr(1,np1,k)-vb(i,np1,iv)*tw
  815 continue
c
c     case m = 1 through nlat-1
c
      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 821 k=1,nt
      do 821 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 821 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
  821 continue
      if(mlat .eq. 0) go to 820
      i = imid
      do 822 k=1,nt
      do 822 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)
  822 continue
  820 continue
      return
      end
      subroutine vhagci(nlat,nlon,wvhagc,lvhagc,dwork,ldwork,ierror)
      dimension wvhagc(1)
      double precision dwork(*)
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 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 .lt. 2*(lzz1+labc)+nlon+imid+15) return
      ierror = 4
      if (ldwork .lt. 2*nlat*(nlat+1)+1) return
      ierror = 0
c
c     compute gaussian points in first nlat+1 words of dwork
c     double precision
c
      lwk = nlat*(nlat+2)

      jw1 = 1
c     jw2 = jw1+nlat+nlat
c     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
c
c     set first imid words of double precision weights in dwork
c     as single precision in first imid words of wvhagc
c
      call setwts(imid,dwork(nlat+1),wvhagc)
c
c     first nlat+1 words of dwork contain  double theta
c
c     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))
      return
      end
      subroutine setwts(imid,dwts,wts)
c
c     set first imid =(nlat+1)/2 of double precision weights in dwts
c     as single precision in wts
c
      dimension dwts(imid),wts(imid)
      double precision dwts
      do 1 i=1,imid
      wts(i) = dwts(i)
    1 continue
      return
      end


      SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG,
     $                   T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2,
     $                   WR, WI, ILO, SCALE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a Hamiltonian matrix,
C
C                   [  A   G  ]         T        T
C             H  =  [       T ],   G = G,   Q = Q,                  (1)
C                   [  Q  -A  ]
C
C     where A, G and Q are real n-by-n matrices.
C
C     Due to the structure of H all eigenvalues appear in pairs
C     (lambda,-lambda). This routine computes the eigenvalues of H
C     using an algorithm based on the symplectic URV and the periodic
C     Schur decompositions as described in [1],
C
C           T       [  T   G  ]
C          U H V =  [       T ],                                    (2)
C                   [  0   S  ]
C
C     where U and V are 2n-by-2n orthogonal symplectic matrices,
C     S is in real Schur form and T is upper triangular.
C
C     The algorithm is backward stable and preserves the eigenvalue
C     pairings in finite precision arithmetic.
C
C     Optionally, a symplectic balancing transformation to improve the
C     conditioning of eigenvalues is computed (see MB04DD). In this
C     case, the matrix H in decomposition (2) must be replaced by the
C     balanced matrix.
C
C     The SLICOT Library routine MB03ZD can be used to compute invariant
C     subspaces of H from the output of this routine.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     BALANC  CHARACTER*1
C             Indicates how H should be diagonally scaled and/or
C             permuted to reduce its norm.
C             = 'N': Do not diagonally scale or permute;
C             = 'P': Perform symplectic permutations to make the matrix
C                    closer to Hamiltonian Schur form. Do not diagonally
C                    scale;
C             = 'S': Diagonally scale the matrix, i.e., replace A, G and
C                    Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where
C                    D is a diagonal matrix chosen to make the rows and
C                    columns of H more equal in norm. Do not permute;
C             = 'B': Both diagonally scale and permute A, G and Q.
C             Permuting does not change the norm of H, but scaling does.
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to compute the full
C             decomposition (2) or the eigenvalues only, as follows:
C             = 'E': compute the eigenvalues only;
C             = 'S': compute matrices T and S of (2);
C             = 'G': compute matrices T, S and G of (2).
C
C     JOBU    CHARACTER*1
C             Indicates whether or not the user wishes to compute the
C             orthogonal symplectic matrix U of (2) as follows:
C             = 'N': the matrix U is not computed;
C             = 'U': the matrix U is computed.
C
C     JOBV    CHARACTER*1
C             Indicates whether or not the user wishes to compute the
C             orthogonal symplectic matrix V of (2) as follows:
C             = 'N': the matrix V is not computed;
C             = 'V': the matrix V is computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A. N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, this array is overwritten. If JOB = 'S' or
C             JOB = 'G', the leading N-by-N part of this array contains
C             the matrix S in real Schur form of decomposition (2).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     QG      (input/output) DOUBLE PRECISION array, dimension
C                            (LDQG,N+1)
C             On entry, the leading N-by-N+1 part of this array must
C             contain in columns 1:N the lower triangular part of the
C             matrix Q and in columns 2:N+1 the upper triangular part
C             of the matrix G.
C             On exit, this array is overwritten. If JOB = 'G', the
C             leading N-by-N+1 part of this array contains in columns
C             2:N+1 the matrix G of decomposition (2).
C
C     LDQG    INTEGER
C             The leading dimension of the array QG.  LDQG >= max(1,N).
C
C     T       (output) DOUBLE PRECISION array, dimension (LDT,N)
C             On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N
C             part of this array contains the upper triangular matrix T
C             of the decomposition (2). Otherwise, this array is used as
C             workspace.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1,N).
C
C     U1      (output) DOUBLE PRECISION array, dimension (LDU1,N)
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the (1,1) block of the orthogonal
C             symplectic matrix U of decomposition (2).
C
C     LDU1    INTEGER
C             The leading dimension of the array U1.  LDU1 >= 1.
C             LDU1 >= N,    if JOBU = 'U'.
C
C     U2      (output) DOUBLE PRECISION array, dimension (LDU2,N)
C             On exit, if JOBU = 'U', the leading N-by-N part of this
C             array contains the (2,1) block of the orthogonal
C             symplectic matrix U of decomposition (2).
C
C     LDU2    INTEGER
C             The leading dimension of the array U2.  LDU2 >= 1.
C             LDU2 >= N,    if JOBU = 'U'.
C
C     V1      (output) DOUBLE PRECISION array, dimension (LDV1,N)
C             On exit, if JOBV = 'V', the leading N-by-N part of this
C             array contains the (1,1) block of the orthogonal
C             symplectic matrix V of decomposition (2).
C
C     LDV1    INTEGER
C             The leading dimension of the array V1.  LDV1 >= 1.
C             LDV1 >= N,    if JOBV = 'V'.
C
C     V2      (output) DOUBLE PRECISION array, dimension (LDV2,N)
C             On exit, if JOBV = 'V', the leading N-by-N part of this
C             array contains the (2,1) block of the orthogonal
C             symplectic matrix V of decomposition (2).
C
C     LDV2    INTEGER
C             The leading dimension of the array V2.  LDV2 >= 1.
C             LDV2 >= N,    if JOBV = 'V'.
C
C     WR      (output) DOUBLE PRECISION array, dimension (N)
C     WI      (output) DOUBLE PRECISION array, dimension (N)
C             On exit, the leading N elements of WR and WI contain the
C             real and imaginary parts, respectively, of N eigenvalues
C             that have nonnegative imaginary part. Their complex
C             conjugate eigenvalues are not stored. If imaginary parts
C             are zero (i.e., for real eigenvalues), only positive
C             eigenvalues are stored.
C
C     ILO     (output) INTEGER
C             ILO is an integer value determined when H was balanced.
C             The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1.
C             The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or
C             I = 1,...,ILO-1.
C
C     SCALE   (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if BALANC <> 'N', the leading N elements of this
C             array contain details of the permutation and/or scaling
C             factors applied when balancing H, see MB04DD.
C             This array is not referenced if BALANC = 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK, and   DWORK(2)  returns the 1-norm of the
C             scaled (if BALANC = 'S' or 'B') Hamiltonian matrix.
C             On exit, if  INFO = -25,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  (input) INTEGER
C             The dimension of the array DWORK. LDWORK >= max( 2, 8*N ).
C             Moreover:
C             If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N',
C                LDWORK >= 7*N+N*N.
C             If JOB = 'G' and JOBU = 'N' and JOBV = 'N',
C                LDWORK >= max( 7*N+N*N, 2*N+3*N*N ).
C             If JOB = 'G' and JOBU = 'U' and JOBV = 'N',
C                LDWORK >= 7*N+2*N*N.
C             If JOB = 'G' and JOBU = 'N' and JOBV = 'V',
C                LDWORK >= 7*N+2*N*N.
C             If JOB = 'G' and JOBU = 'U' and JOBV = 'V',
C                LDWORK >= 7*N+N*N.
C             For good performance, LDWORK must generally be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO     (output) INTEGER
C              = 0:  successful exit;
C              < 0:  if INFO = -i, the i-th argument had an illegal
C                    value;
C              > 0:  if INFO = i, the periodic QR algorithm failed to
C                    compute all the eigenvalues, elements i+1:N of WR
C                    and WI contain eigenvalues which have converged.
C
C     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., and Xu, H.
C         A numerically stable, structure preserving method for
C         computing the eigenvalues of real Hamiltonian or symplectic
C         pencils.
C         Numer. Math., Vol. 78(3), pp. 329-358, 1998.
C
C     [2] Benner, P., Mehrmann, V., and Xu, H.
C         A new method for computing the stable invariant subspace of a
C         real Hamiltonian matrix,  J. Comput. Appl. Math., vol. 86,
C         pp. 17-43, 1997.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU).
C     V. Sima, Aug. 2011, Oct. 2011, July 2012, Mar. 2015, May 2015.
C
C     KEYWORDS
C
C     Eigenvalues, invariant subspace, Hamiltonian matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          BALANC, JOB, JOBU, JOBV
      INTEGER            ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1,
     $                   LDV2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*),
     $                   T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*),
     $                   V2(LDV2,*), WI(*), WR(*)
C     .. Local Scalars ..
      CHARACTER          UCHAR, VCHAR
      LOGICAL            LPERM, LQUERY, LSCAL, SCALEH, WANTG, WANTS,
     $                   WANTU, WANTV
      INTEGER            I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW,
     $                   PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT
      DOUBLE PRECISION   BIGNUM, CSCALE, EPS, HNR1, HNRM, SMLNUM, TEMP,
     $                   TEMPI, TEMPR
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, MA02ID
      EXTERNAL           DLAMCH, LSAME, MA02ID
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET,
     $                   DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB,
     $                   XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, SQRT
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO = 0
      LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' )
      LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' )
      WANTS = LSAME( JOB,    'S' ) .OR. LSAME( JOB,    'G' )
      WANTG = LSAME( JOB,  'G' )
      WANTU = LSAME( JOBU, 'U' )
      WANTV = LSAME( JOBV, 'V' )
C
      IF ( WANTG ) THEN
         IF ( WANTU .AND. WANTV ) THEN
            WRKMIN = MAX( 2, 7*N + N*N )
         ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN
            WRKMIN = MAX( 2, 7*N + N*N, 2*N + 3*N*N )
         ELSE
            WRKMIN = MAX( 2, 7*N + 2*N*N )
         END IF
      ELSE
         IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN
            WRKMIN = MAX( 2, 7*N + N*N )
         ELSE
            WRKMIN = MAX( 2, 8*N )
         END IF
      END IF
C
C     Test the scalar input parameters.
C
      IF ( .NOT.LPERM .AND. .NOT.LSCAL
     $     .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -3
      ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN
         INFO = -13
      ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN
         INFO = -15
      ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN
         INFO = -17
      ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN
         INFO = -19
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( LQUERY ) THEN
            IF ( N.EQ.0 ) THEN
               WRKOPT = TWO
            ELSE
               PTAUR = 5*N
               PDW   = PTAUR + N
               IF ( .NOT.WANTU .AND. .NOT.WANTV  )
     $            PDW  = PDW + N*N
               CALL MB04TB( 'No Transpose', 'Transpose', N, N, DWORK,
     $                      LDT, DWORK, LDT, DWORK, LDT, DWORK, LDT,
     $                      DWORK, DWORK, DWORK, DWORK, DWORK, -1,
     $                      IERR )
               WRKOPT = MAX( WRKMIN, INT( DWORK(1) ) + PDW )
C
               IF ( WANTU .OR. WANTV ) THEN
                  IF ( .NOT.WANTG ) THEN
                     PDW = PTAUR + N
                     IF ( WANTU .AND. WANTV )
     $                  PDW = PDW + N
                  ELSE
                     PDW = PTAUR + N*N
                     IF ( .NOT.WANTU .AND. WANTV )
     $                  PDW = PDW + 2*N
                  END IF
                  CALL MB04QB( 'No Transpose', 'No Transpose',
     $                          'No Transpose','Columnwise',
     $                         'Columnwise', N, N, N, DWORK, LDT, DWORK,
     $                         LDT, DWORK, LDT, DWORK, LDT, DWORK,
     $                         DWORK, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               END IF
            END IF
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         ELSE IF ( LDWORK.LT.WRKMIN ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -25
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB03XD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      ILO = 0
      IF( N.EQ.0 ) THEN
         DWORK(1) = TWO
         DWORK(2) = ZERO
         RETURN
      END IF
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
C
C     Scale H if maximal element is outside range [SMLNUM,BIGNUM].
C
      HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG,
     $               DWORK )
      SCALEH = .FALSE.
      IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN
         SCALEH = .TRUE.
         CSCALE = SMLNUM
      ELSE IF( HNRM.GT.BIGNUM ) THEN
         SCALEH = .TRUE.
         CSCALE = BIGNUM
      END IF
      IF ( SCALEH ) THEN
        CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR )
        CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG,
     $               IERR )
      END IF
C
C     Balance the matrix and compute the 1-norm.
C
      IF ( LPERM .OR. LSCAL ) THEN
         CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR )
      ELSE
         ILO = 1
      END IF
      HNR1 = MA02ID( 'Hamiltonian', '1-norm', N, A, LDA, QG, LDQG,
     $               DWORK )
C
C     Copy A to T and multiply A by -1.
C
      CALL DLACPY( 'All', N, N, A, LDA, T, LDT )
      CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR )
C
C     ---------------------------------------------
C     Step 1: Compute symplectic URV decomposition.
C     ---------------------------------------------
C
      PCSL  = 1
      PCSR  = PCSL  + 2*N
      PTAUL = PCSR  + 2*N
      PTAUR = PTAUL + N
      PDW   = PTAUR + N

      IF ( .NOT.WANTU .AND. .NOT.WANTV  ) THEN
C
C         Copy Q and Q' to workspace.
C
         PQ   = PDW
         PDW  = PDW + N*N
         DO 20  J = 1, N
            K = PQ + (N+1)*(J-1)
            L = K
            DWORK(K) = QG(J,J)
            DO 10  I = J+1, N
               K = K + 1
               L = L + N
               TEMP = QG(I,J)
               DWORK(K) = TEMP
               DWORK(L) = TEMP
   10       CONTINUE
   20    CONTINUE
      ELSE IF ( WANTU ) THEN
C
C         Copy Q and Q' to U2.
C
         DO 40  J = 1, N
            U2(J,J) = QG(J,J)
            DO 30 I = J+1, N
               TEMP = QG(I,J)
               U2(I,J) = TEMP
               U2(J,I) = TEMP
   30       CONTINUE
   40    CONTINUE
      ELSE
C
C         Copy Q and Q' to V2.
C
         DO 60  J = 1, N
            V2(J,J) = QG(J,J)
            DO 50 I = J+1, N
               TEMP = QG(I,J)
               V2(I,J) = TEMP
               V2(J,I) = TEMP
   50       CONTINUE
   60    CONTINUE
      END IF
C
C     Transpose G.
C
      DO 80 J = 1, N
         DO 70 I = J+1, N
            QG(I,J+1) = QG(J,I+1)
   70    CONTINUE
   80 CONTINUE
C
      IF ( .NOT.WANTU .AND. .NOT.WANTV  ) THEN
         CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A,
     $                LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL),
     $                DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
      ELSE IF ( WANTU ) THEN
         CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A,
     $                LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL),
     $                DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
      ELSE
         CALL MB04TB( 'No Transpose', 'Transpose', N, ILO, T, LDT, A,
     $                LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL),
     $                DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
      IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN
         IF ( N.GT.1 )
     $     CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG )
      ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN
         IF ( N.GT.1 ) THEN
            CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG )
            CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2),
     $                   LDQG )
         END IF
      ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN
         IF ( N.GT.1 ) THEN
            CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 )
            CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG )
         END IF
      ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN
         IF ( N.GT.1 )
     $     CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT,
     $                  DWORK(PDW+N*N+N), N-1 )
      ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN
         IF ( N.GT.2 )
     $     CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA,
     $                  DWORK(PDW+N*N+N), N-2 )
      ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN
         IF ( N.GT.1 )
     $     CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT,
     $                  DWORK(PDW+N), N-1 )
         IF ( N.GT.2 )
     $     CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 )
      END IF
C
C     ----------------------------------------------
C     Step 2:  Compute periodic Schur decomposition.
C     ----------------------------------------------
C
      IF ( N.GT.2 )
     $   CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA )
      IF ( N.GT.1 )
     $   CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT )
      IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN
         PBETA = 1
      ELSE
         PBETA = PDW
      END IF
C
      IF ( .NOT.WANTG ) THEN
C
C        Workspace requirements: 2*N (8*N with U or V).
C
         PDW = PBETA + N
         IF ( WANTU ) THEN
            UCHAR = 'I'
         ELSE
            UCHAR = 'N'
         END IF
         IF ( WANTV ) THEN
            VCHAR = 'I'
         ELSE
            VCHAR = 'N'
         END IF
         CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1,
     $                LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW),
     $                LDWORK-PDW+1, INFO )
         IF ( INFO.NE.0 )
     $      GO TO 90
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
      ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN
C
C        Workspace requirements: 3*N*N + 2*N.
C
         PQ    = PBETA + N
         PZ    = PQ + N*N
         PDW   = PZ + N*N
         CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T,
     $                LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI,
     $                DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO )
         IF ( INFO.NE.0 )
     $      GO TO 90
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG )
      ELSE IF ( WANTU .AND. .NOT.WANTV ) THEN
C
C        Workspace requirements: 2*N*N + 7*N.
C
         PQ    = PBETA + N
         PDW   = PQ + N*N
         CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T,
     $                LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA),
     $                DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1,
     $                INFO )
         IF ( INFO.NE.0 )
     $      GO TO 90
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW
     $                         + (N-1)*(N-1) - 1 )
         IF ( N.GT.1 )
     $      CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1),
     $                   LDT )
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $                U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG )
C
      ELSE IF ( .NOT.WANTU .AND. WANTV ) THEN
C
C        Workspace requirements: 2*N*N + 7*N
C
         PZ    = PBETA + N
         PDW   = PZ + N*N
         CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T,
     $                LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA),
     $                DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1,
     $                INFO )
         IF ( INFO.NE.0 )
     $      GO TO 90
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW
     $                         + (N-1)*(N-1) - 1 )
         IF ( N.GT.2 )
     $      CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1),
     $                   LDA )
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG )
C
      ELSE
C
C        Workspace requirements: N*N + 7*N.
C
         PDW = PBETA + N
         CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T,
     $                LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA),
     $                DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1,
     $                INFO )
         IF ( INFO.NE.0 )
     $      GO TO 90
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW
     $                         + (N-1)*(N-1) - 1 )
         IF ( N.GT.1 )
     $      CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1),
     $                   LDT )
         IF ( N.GT.2 )
     $      CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA )
         CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE,
     $               U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N )
         CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE,
     $               DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG )
      END IF
C
   90 CONTINUE
C
C     Compute square roots of eigenvalues and rescale.
C
      I = INFO + 1
C     WHILE I <= N
  100 CONTINUE
      IF ( I.LE.N ) THEN
         TEMPR = WR(I)
         TEMPI = WI(I)
         TEMP  = DWORK(PBETA + I - 1)
         IF ( TEMP.GT.ZERO )
     $      TEMPR = -TEMPR
         TEMP  = ABS( TEMP )
         IF ( TEMPI.EQ.ZERO ) THEN
            IF ( TEMPR.LT.ZERO ) THEN
               WR(I) = ZERO
               WI(I) = SQRT( TEMP ) * SQRT( -TEMPR )
            ELSE
               WR(I) = SQRT( TEMP ) * SQRT(  TEMPR )
               WI(I) = ZERO
            END IF
            I = I + 1
         ELSE
            CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) )
            WR(I) = WR(I) * SQRT( TEMP )
            IF ( TEMP.GT.ZERO ) THEN
               WI(I) = WI(I) * SQRT( TEMP )
            ELSE
               WI(I) = ZERO
            END IF
            WR(I+1) = -WR(I)
            WI(I+1) =  WI(I)
            I = I + 2
         END IF
         GO TO 100
C        END WHILE
      END IF
C
      IF ( SCALEH ) THEN
C
C        Undo scaling.
C
         CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA,
     $                IERR )
         CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR )
         If ( WANTG )
     $      CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2),
     $                   LDQG, IERR )
         CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR )
         CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR )
         HNR1 = HNR1 * HNRM / CSCALE
      END IF
C
      IF ( INFO.NE.0 )
     $   RETURN
C
      IF ( ILO.GT.N ) THEN
         DWORK(1) = DBLE( WRKOPT )
         DWORK(2) = HNR1
         RETURN
      END IF
C
C     -----------------------------------------------
C     Step 3:  Compute orthogonal symplectic factors.
C     -----------------------------------------------
C
C     Fix CSL and CSR for MB04QB.
C
      IF ( WANTU )
     $   CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 )
      IF ( WANTV )
     $   CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 )
      ILO1 = MIN( N, ILO + 1 )
C
      IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN
C
C        Workspace requirements: 7*N.
C
         PDW = PTAUR
         CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 )
         CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT )
         CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1,
     $                QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1),
     $                LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2),
     $                DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1,
     $                IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 )
         CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 )
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT )
C
      ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN
C
C        Workspace requirements: 7*N.
C
         PDW = PTAUR + N
         CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Rowwise', N-ILO, N, N-ILO,
     $                QG(ILO1,ILO), LDQG, QG(ILO,ILO1), LDQG,
     $                V1(ILO1,1), LDV1, V2(ILO1,1), LDV2,
     $                DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
      ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN
C
C        Workspace requirements: 8*N.
C
         PDW = PTAUR + N
         CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 )
         CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT )
         CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Rowwise', N-ILO, N, N-ILO,
     $                QG(ILO1,ILO), LDQG, U2(ILO,ILO1), LDU2,
     $                V1(ILO1,1), LDV1, V2(ILO1,1), LDV2,
     $                DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1),
     $                DWORK(PDW+N), LDWORK-PDW-N+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 )
C
         CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG )
         CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1,
     $                T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1),
     $                LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2),
     $                DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1,
     $                IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 )
         CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 )
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT )
C
      ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN
C
C        Workspace requirements: 6*N + N*N.
C
         PQ  = PTAUR
         PDW = PQ + N*N
         CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N )
         CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1,
     $                T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N,
     $                U1(ILO,1), LDU1, U2(ILO,1), LDU2,
     $                DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT )
C
      ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN
C
C        Workspace requirements: 7*N + N*N.
C
         PQ  = PTAUR + N
         PDW = PQ + N*N
         CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N )
         CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Rowwise', N-ILO, N, N-ILO,
     $                A(ILO1,ILO), LDA, DWORK(PQ+ILO*N+ILO-1),
     $                N, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2,
     $                DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1),
     $                DWORK(PDW+N), LDWORK-PDW-N+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 )
         IF ( N.GT.2 )
     $      CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA )
C
      ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN
C
C        Workspace requirements: 6*N + N*N.
C
         PDW = PTAUR + N
         CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Rowwise', N-ILO, N, N-ILO,
     $                A(ILO1,ILO), LDA, U2(ILO,ILO1), LDU2, V1(ILO1,1),
     $                LDV1, V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2),
     $                DWORK(PTAUR+ILO-1), DWORK(PDW), LDWORK-PDW+1,
     $                IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
C
         PQ  = PTAUR
         PDW = PQ + N*N
         CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N )
         CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 )
         CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose',
     $                'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1,
     $                T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N,
     $                U1(ILO,1), LDU1, U2(ILO,1), LDU2,
     $                DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1),
     $                DWORK(PDW), LDWORK-PDW+1, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 )
         IF ( N.GT.2 )
     $      CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA )
         IF ( N.GT.1 )
     $      CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT )
      END IF
C
      DWORK(1) = DBLE( WRKOPT )
      DWORK(2) = HNR1
      RETURN
C *** Last line of MB03XD ***
      END


      SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
     $                   CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve the least-squares filtering problem recursively in time.
C     Each subroutine call implements one time update of the solution.
C     The algorithm uses a fast QR-decomposition based approach.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JP      CHARACTER*1
C             Indicates whether the user wishes to apply both prediction
C             and filtering parts, as follows:
C             = 'B':  Both prediction and filtering parts are to be
C                     applied;
C             = 'P':  Only the prediction section is to be applied.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The length of the impulse response of the equivalent
C             transversal filter model.  L >= 1.
C
C     LAMBDA  (input) DOUBLE PRECISION
C             Square root of the forgetting factor.
C             For tracking capabilities and exponentially stable error
C             propagation, LAMBDA < 1.0 (strict inequality) should
C             be used.  0.0 < LAMBDA <= 1.0.
C
C     XIN     (input) DOUBLE PRECISION
C             The input sample at instant n.
C             (The situation just before and just after the call of
C             the routine are denoted by instant (n-1) and instant n,
C             respectively.)
C
C     YIN     (input) DOUBLE PRECISION
C             If JP = 'B', then YIN must contain the reference sample
C             at instant n.
C             Otherwise, YIN is not referenced.
C
C     EFOR    (input/output) DOUBLE PRECISION
C             On entry, this parameter must contain the square root of
C             exponentially weighted forward prediction error energy
C             at instant (n-1).  EFOR >= 0.0.
C             On exit, this parameter contains the square root of the
C             exponentially weighted forward prediction error energy
C             at instant n.
C
C     XF      (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the transformed forward
C             prediction variables at instant (n-1).
C             On exit, this array contains the transformed forward
C             prediction variables at instant n.
C
C     EPSBCK  (input/output) DOUBLE PRECISION array, dimension (L+1)
C             On entry, the leading L elements of this array must
C             contain the normalized a posteriori backward prediction
C             error residuals of orders zero through L-1, respectively,
C             at instant (n-1), and EPSBCK(L+1) must contain the
C             square-root of the so-called "conversion factor" at
C             instant (n-1).
C             On exit, this array contains the normalized a posteriori
C             backward prediction error residuals, plus the square root
C             of the conversion factor at instant n.
C
C     CTETA   (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the cosines of the
C             rotation angles used in time updates, at instant (n-1).
C             On exit, this array contains the cosines of the rotation
C             angles at instant n.
C
C     STETA   (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, this array must contain the sines of the
C             rotation angles used in time updates, at instant (n-1).
C             On exit, this array contains the sines of the rotation
C             angles at instant n.
C
C     YQ      (input/output) DOUBLE PRECISION array, dimension (L)
C             On entry, if JP = 'B', then this array must contain the
C             orthogonally transformed reference vector at instant
C             (n-1). These elements are also the tap multipliers of an
C             equivalent normalized lattice least-squares filter.
C             Otherwise, YQ is not referenced and can be supplied as
C             a dummy array (i.e., declare this array to be YQ(1) in
C             the calling program).
C             On exit, if JP = 'B', then this array contains the
C             orthogonally transformed reference vector at instant n.
C
C     EPOS    (output) DOUBLE PRECISION
C             The a posteriori forward prediction error residual.
C
C     EOUT    (output) DOUBLE PRECISION
C             If JP = 'B', then EOUT contains the a posteriori output
C             error residual from the least-squares filter at instant n.
C
C     SALPH   (output) DOUBLE PRECISION array, dimension (L)
C             The element SALPH(i), i=1,...,L, contains the opposite of
C             the i-(th) reflection coefficient for the least-squares
C             normalized lattice predictor (whose value is -SALPH(i)).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  an element to be annihilated by a rotation is less
C                   than the machine precision (see LAPACK Library
C                   routine DLAMCH).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The output error EOUT at instant n, denoted by EOUT(n), is the
C     reference sample minus a linear combination of L successive input
C     samples:
C
C                           L-1
C        EOUT(n) = YIN(n) - SUM h_i * XIN(n-i),
C                           i=0
C
C     where YIN(n) and XIN(n) are the scalar samples at instant n.
C     A least-squares filter uses those h_0,...,h_{L-1} which minimize
C     an exponentially weighted sum of successive output errors squared:
C
C         n
C        SUM [LAMBDA**(2(n-k)) * EOUT(k)**2].
C        k=1
C
C     Each subroutine call performs a time update of the least-squares
C     filter using a fast least-squares algorithm derived from a
C     QR decomposition, as described in references [1] and [2] (the
C     notation from [2] is followed in the naming of the arrays).
C     The algorithm does not compute the parameters h_0,...,h_{L-1} from
C     the above formula, but instead furnishes the parameters of an
C     equivalent normalized least-squares lattice filter, which are
C     available from the arrays SALPH (reflection coefficients) and YQ
C     (tap multipliers), as well as the exponentially weighted input
C     signal energy
C
C         n                                              L
C        SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2.
C        k=1                                            i=1
C
C     For more details on reflection coefficients and tap multipliers,
C     references [2] and [4] are recommended.
C
C     REFERENCES
C
C     [1]  Proudler, I. K., McWhirter, J. G., and Shepherd, T. J.
C          Fast QRD based algorithms for least-squares linear
C          prediction.
C          Proceedings IMA Conf. Mathematics in Signal Processing
C          Warwick, UK, December 1988.
C
C     [2]  Regalia, P. A., and Bellanger, M. G.
C          On the duality between QR methods and lattice methods in
C          least-squares adaptive filtering.
C          IEEE Trans. Signal Processing, SP-39, pp. 879-891,
C          April 1991.
C
C     [3]  Regalia, P. A.
C          Numerical stability properties of a QR-based fast
C          least-squares algorithm.
C          IEEE Trans. Signal Processing, SP-41, June 1993.
C
C     [4]  Lev-Ari, H., Kailath, T., and Cioffi, J.
C          Least-squares adaptive lattice and transversal filters:
C          A unified geometric theory.
C          IEEE Trans. Information Theory, IT-30, pp. 222-236,
C          March 1984.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O(L) operations for each subroutine call.
C     It is backward consistent for all input sequences XIN, and
C     backward stable for persistently exciting input sequences,
C     assuming LAMBDA < 1.0 (see [3]).
C     If the condition of the signal is very poor (IWARN = 1), then the
C     results are not guaranteed to be reliable.
C
C     FURTHER COMMENTS
C
C     1.  For tracking capabilities and exponentially stable error
C         propagation, LAMBDA < 1.0 should be used.  LAMBDA is typically
C         chosen slightly less than 1.0 so that "past" data are
C         exponentially forgotten.
C     2.  Prior to the first subroutine call, the variables must be
C         initialized. The following initial values are recommended:
C
C         XF(i) = 0.0,        i=1,...,L
C         EPSBCK(i) = 0.0     i=1,...,L
C         EPSBCK(L+1) = 1.0
C         CTETA(i) = 1.0      i=1,...,L
C         STETA(i) = 0.0      i=1,...,L
C         YQ(i) = 0.0         i=1,...,L
C
C         EFOR = 0.0          (exact start)
C         EFOR = "small positive constant" (soft start).
C
C         Soft starts are numerically more reliable, but result in a
C         biased least-squares solution during the first few iterations.
C         This bias decays exponentially fast provided LAMBDA < 1.0.
C         If sigma is the standard deviation of the input sequence
C         XIN, then initializing EFOR = sigma*1.0E-02 usually works
C         well.
C
C     CONTRIBUTOR
C
C     P. A. Regalia (October 1994).
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Kalman filtering, least-squares estimator, optimal filtering,
C     orthogonal transformation, recursive estimation, QR decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JP
      INTEGER           INFO, IWARN, L
      DOUBLE PRECISION  EFOR, EOUT, EPOS, LAMBDA, XIN, YIN
C     .. Array Arguments ..
      DOUBLE PRECISION  CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*),
     $                  YQ(*)
C     .. Local Scalars ..
      LOGICAL           BOTH
      INTEGER           I
      DOUBLE PRECISION  CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLAPY2, DNRM2
      EXTERNAL          DLAMCH, DLAPY2, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARTG, XERBLA
C     .. Intrinsic Functions
      INTRINSIC         ABS, SQRT
C     .. Executable statements ..
C
C     Test the input scalar arguments.
C
      BOTH  = LSAME( JP, 'B' )
      IWARN = 0
      INFO  = 0
C
      IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN
         INFO = -1
      ELSE IF( L.LT.1 ) THEN
         INFO = -2
      ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE  ) ) THEN
         INFO = -3
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'FD01AD', -INFO )
         RETURN
      END IF
C
C     Computation of the machine precision EPS.
C
      EPS = DLAMCH( 'Epsilon' )
C
C     Forward prediction rotations.
C
      FNODE = XIN
C
      DO 10  I = 1, L
         XFI   = XF(I) * LAMBDA
         XF(I) = STETA(I) * FNODE + CTETA(I) * XFI
         FNODE = CTETA(I) * FNODE - STETA(I) * XFI
   10 CONTINUE
C
      EPOS = FNODE * EPSBCK(L+1)
C
C     Update the square root of the prediction energy.
C
      EFOR = EFOR * LAMBDA
      TEMP = DLAPY2( FNODE, EFOR )
      IF ( TEMP.LT.EPS ) THEN
         FNODE = ZERO
         IWARN = 1
      ELSE
         FNODE = FNODE * EPSBCK(L+1)/TEMP
      END IF
      EFOR = TEMP
C
C     Calculate the reflection coefficients and the backward prediction
C     errors.
C
      DO 20 I = L, 1, -1
         IF ( ABS( XF(I) ).LT.EPS )
     $      IWARN = 1
         CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM )
         EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE
         FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I)
         TEMP  = NORM
   20 CONTINUE
C
      EPSBCK(1) = FNODE
C
C     Update to new rotation angles.
C
      NORM = DNRM2( L, EPSBCK, 1 )
      TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) )
      EPSBCK(L+1) = TEMP
C
      DO 30 I = L, 1, -1
         IF ( ABS( EPSBCK(I) ).LT.EPS )
     $      IWARN = 1
         CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM )
         TEMP = NORM
   30 CONTINUE
C
C     Joint process section.
C
      IF ( BOTH) THEN
         FNODE = YIN
C
         DO 40  I = 1, L
            YQI   = YQ(I) * LAMBDA
            YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI
            FNODE = CTETA(I) * FNODE - STETA(I) * YQI
   40    CONTINUE
C
         EOUT = FNODE * EPSBCK(L+1)
      END IF
C
      RETURN
C *** Last line of FD01AD ***
      END