!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file shags.f
!
!     this file contains code and documentation for subroutines
!     shags and shagsi
!
! ... files which must be loaded with shags.f
!
!     sphcom.f, hrfft.f, gaqd.f
!
!     subroutine shags(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
!    1                    wshags,lshags,work,lwork,ierror)
!
!     subroutine shags performs the spherical harmonic analysis
!     on the array g and stores the result in the arrays a and b.
!     the analysis is performed on a gaussian grid in colatitude
!     and an equally spaced grid in longitude.  the associated
!     legendre functions are stored rather than recomputed as they
!     are in subroutine shagc.  the analysis is described below
!     at output parameters a,b.
!
!     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 compu
!            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
!            if nlat is odd the equator will be included as the grid poi
!            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 or equal to 4. the efficiency of the computation is
!            improved when nlon is a product of small prime numbers.
!
!     isym   = 0  no symmetries exist about the equator. the analysis
!                 is performed on the entire sphere.  i.e. on the
!                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
!                 (see description of g below)
!
!            = 1  g 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
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the analysis is performed on the
!                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!
!            = 2  g 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
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the analysis is performed on the
!                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!     nt     the number of analyses.  in the program that calls shags,
!            the arrays g,a and b 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 the arrays g,a and b
!            have only two dimensions.
!
!     g      a two or three dimensional array (see input parameter
!            nt) that contains the discrete function to be analyzed.
!            g(i,j) contains the value of the function at the gaussian
!            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
!            the index ranges are defined above at the input parameter
!            isym.
!
!     idg    the first dimension of the array g as it appears in the
!            program that calls shags. if isym equals zero then idg
!            must be at least nlat.  if isym is nonzero then idg must
!            be at least nlat/2 if nlat is even or at least (nlat+1)/2
!            if nlat is odd.
!
!     jdg    the second dimension of the array g as it appears in the
!            program that calls shags. jdg must be at least nlon.
!
!     mdab   the first dimension of the arrays a and b as it appears
!            in the program that calls shags. mdab must be at least
!            min0((nlon+2)/2,nlat) if nlon is even or at least
!            min0((nlon+1)/2,nlat) if nlon is odd.
!
!     ndab   the second dimension of the arrays a and b as it appears
!            in the program that calls shags. ndab must be at least nlat
!
!     wshags an array which must be initialized by subroutine shagsi.
!            once initialized, wshags can be used repeatedly by shags
!            as long as nlat and nlon remain unchanged.  wshags must
!            not be altered between calls of shags.
!
!     lshags the dimension of the array wshags as it appears in the
!            program that calls shags. define
!
!               l1 = min0(nlat,(nlon+2)/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 lshags must be at least
!
!            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
!
!     work   a real work space which need not be saved
!
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls shags. define
!
!               l2 = nlat/2        if nlat is even or
!               l2 = (nlat+1)/2    if nlat is odd
!
!
!            if isym is zero then lwork must be at least
!
!                  nlat*nlon*(nt+1)
!
!            if isym is nonzero then lwork must be at least
!
!                  l2*nlon*(nt+1)
!
!     **************************************************************
!
!     output parameters
!
!     a,b    both a,b are two or three dimensional arrays (see input
!            parameter nt) that contain the spherical harmonic
!            coefficients in the representation of g(i,j) given in the
!            discription of subroutine shags. for isym=0, a(m,n) and
!            b(m,n) are given by the equations listed below. symmetric
!            versions are used when isym is greater than zero.
!
!     definitions
!
!     1. the normalized associated legendre functions
!
!     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
!                       *sin(theta)**m/(2**n*factorial(n)) times the
!                       (n+m)th derivative of (x**2-1)**n with respect
!                       to x=cos(theta).
!
!     2. the fourier transform of g(i,j).
!
!     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon of
!                       g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
!                       (the first and last terms in this sum
!                       are divided by 2)
!
!     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon of
!                       g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
!
!
!     3. the gaussian points and weights on the sphere
!        (computed by subroutine gaqd).
!
!        theta(1),...,theta(nlat) (gaussian pts in radians)
!        wts(1),...,wts(nlat) (corresponding gaussian weights)
!
!
!     4. the maximum (plus one) longitudinal wave number
!
!            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
!            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
!
!
!     then for m=0,...,mmax-1 and n=m,...,nlat-1 the arrays a,b
!     are given by
!
!     a(m+1,n+1)     =  the sum from i=1 to i=nlat of
!                       c(m+1,i)*wts(i)*pbar(m,n,theta(i))
!
!     b(m+1,n+1)      = the sum from i=1 to nlat of
!                       s(m+1,i)*wts(i)*pbar(m,n,theta(i))
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of isym
!            = 4  error in the specification of nt
!            = 5  error in the specification of idg
!            = 6  error in the specification of jdg
!            = 7  error in the specification of mdab
!            = 8  error in the specification of ndab
!            = 9  error in the specification of lshags
!            = 10 error in the specification of lwork
!
!
! ****************************************************************
!
!     subroutine shagsi(nlat,nlon,wshags,lshags,work,lwork,dwork,ldwork,
!    +                  ierror)
!
!     subroutine shagsi initializes the array wshags which can then
!     be used repeatedly by subroutines shags. it precomputes
!     and stores in wshags quantities such as gaussian weights,
!     legendre polynomial coefficients, and fft trigonometric tables.
!
!     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 compu
!            in radians in theta(1),...,theta(nlat) by subroutine gaqd.
!            if nlat is odd the equator will be included as the grid poi
!            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 or equal to 4. the efficiency of the computation is
!            improved when nlon is a product of small prime numbers.
!
!     wshags an array which must be initialized by subroutine shagsi.
!            once initialized, wshags can be used repeatedly by shags
!            as long as nlat and nlon remain unchanged.  wshags must
!            not be altered between calls of shags.
!
!     lshags the dimension of the array wshags as it appears in the
!            program that calls shags. define
!
!               l1 = min0(nlat,(nlon+2)/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 lshags must be at least
!
!            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
!
!     work   a real work space which need not be saved
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls shagsi. lwork must be at least
!            4*nlat*(nlat+2)+2 in the routine calling shagsi
!
!     dwork   a double precision work array that does not have to be saved.
!
!     ldwork  the length of dwork in the calling routine.  ldwork must
!             be at least nlat*(nlat+4)
!
!     output parameter
!
!     wshags an array which must be initialized before calling shags or
!            once initialized, wshags can be used repeatedly by shags or
!            as long as nlat and nlon remain unchanged.  wshags must not
!            altered between calls of shasc.
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of lshags
!            = 4  error in the specification of lwork
!            = 5  error in the specification of ldwork
!            = 6  failure in gaqd to compute gaussian points
!                 (due to failure in eigenvalue routine)
!
!
! ****************************************************************
      SUBROUTINE SHAGS(Nlat,Nlon,Mode,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshags,&
                     & Lshags,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL A , B , G , Work , Wshags
      INTEGER Idg , Ierror , ifft , ipmn , iw , iwts , Jdg , l , l1 ,   &
            & l2 , lat , late , lp , Lshags , Lwork , Mdab , Mode ,     &
            & Ndab , Nlat , Nlon
      INTEGER Nt
!     subroutine shags performs the spherical harmonic analysis on
!     a gaussian grid on the array(s) in g and returns the coefficients
!     in array(s) a,b. the necessary legendre polynomials are fully
!     stored in this version.
!
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshags(Lshags) , Work(Lwork)
!     check input parameters
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Mode<0 .OR. Mode>2 ) RETURN
!     set m limit for pmn
      l = MIN0((Nlon+2)/2,Nlat)
!     set gaussian point nearest equator pointer
      late = (Nlat+MOD(Nlat,2))/2
!     set number of grid points for analysis/synthesis
      lat = Nlat
      IF ( Mode/=0 ) lat = late
      Ierror = 4
      IF ( Nt<1 ) RETURN
      Ierror = 5
      IF ( Idg<lat ) RETURN
      Ierror = 6
      IF ( Jdg<Nlon ) RETURN
      Ierror = 7
      IF ( Mdab<l ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      l1 = l
      l2 = late
      Ierror = 9
!     check permanent work space length
!
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshags<lp ) RETURN
      Ierror = 10
!     check temporary work space length
      IF ( Mode==0 .AND. Lwork<Nlat*Nlon*(Nt+1) ) RETURN
      IF ( Mode/=0 .AND. Lwork<l2*Nlon*(Nt+1) ) RETURN
      Ierror = 0
!     set starting address for gaussian wts ,fft values,
!     and fully stored legendre polys in wshags
      iwts = 1
      ifft = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1)) + 1
      ipmn = ifft + Nlon + 15
!     set pointer for internal storage of g
      iw = lat*Nlon*Nt + 1
      CALL SHAGS1(Nlat,Nlon,l,lat,Mode,G,Idg,Jdg,Nt,A,B,Mdab,Ndab,      &
                & Wshags(iwts),Wshags(ifft),Wshags(ipmn),late,Work,     &
                & Work(iw))
    END SUBROUTINE SHAGS
    
    
    SUBROUTINE SHAGS1(Nlat,Nlon,L,Lat,Mode,Gs,Idg,Jdg,Nt,A,B,Mdab,    &
                      & Ndab,Wts,Wfft,Pmn,Late,G,Work)
      IMPLICIT NONE
      REAL A , B , G , Gs , Pmn , sfn , t1 , t2 , Wfft , Work , Wts
      INTEGER i , Idg , is , j , Jdg , k , L , Lat , Late , lm1 , lp1 , &
            & m , Mdab , mml1 , mn , Mode , mp1 , mp2 , ms , Ndab
      INTEGER nl2 , Nlat , Nlon , np1 , ns , Nt
      DIMENSION Gs(Idg,Jdg,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt) ,    &
              & G(Lat,Nlon,Nt)
      DIMENSION Wfft(1) , Pmn(Late,1) , Wts(Nlat) , Work(1)
!     set gs array internally in shags1
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = Gs(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
!     do fourier transform
      DO k = 1 , Nt
         CALL HRFFTF(Lat,Nlon,G(1,1,k),Lat,Wfft,Work)
      ENDDO
 
!     scale result
      sfn = 2.0/FLOAT(Nlon)
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = sfn*G(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
!     compute using gaussian quadrature
!     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
!     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
!     here ga,gb are the cos(phi),sin(phi) coefficients of
!     the fourier expansion of g(theta,phi) in phi.  as a result
!     of the above fourier transform they are stored in array
!     g as follows:
!     for each theta(i) and k= l-1
!     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
!     correspond to
!     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-2)
!     whenever 2*l-2 = nlon exactly
!     initialize coefficients to zero
      DO k = 1 , Nt
         DO np1 = 1 , Nlat
            DO mp1 = 1 , L
               A(mp1,np1,k) = 0.0
               B(mp1,np1,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
!     set mp1 limit on b(mp1) calculation
      lm1 = L
      IF ( Nlon==L+L-2 ) lm1 = L - 1
 
      IF ( Mode==0 ) THEN
!     for full sphere (mode=0) and even/odd reduction:
!     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
!     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
         nl2 = Nlat/2
         DO k = 1 , Nt
            DO j = 1 , Nlon
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,j,k)
                  t2 = G(is,j,k)
                  G(i,j,k) = Wts(i)*(t1+t2)
                  G(is,j,k) = Wts(i)*(t1-t2)
               ENDDO
!     adjust equator if necessary(nlat odd)
               IF ( MOD(Nlat,2)/=0 ) G(Late,j,k) = Wts(Late)*G(Late,j,k)
            ENDDO
         ENDDO
!     set m = 0 coefficients first
         mp1 = 1
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         DO k = 1 , Nt
            DO i = 1 , Late
               is = Nlat - i + 1
               DO np1 = 1 , Nlat , 2
!     n even
                  A(1,np1,k) = A(1,np1,k) + G(i,1,k)*Pmn(i,mml1+np1)
               ENDDO
               DO np1 = 2 , Nlat , 2
!     n odd
                  A(1,np1,k) = A(1,np1,k) + G(is,1,k)*Pmn(i,mml1+np1)
               ENDDO
            ENDDO
         ENDDO
!     compute m.ge.1  coefficients next
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            mp2 = mp1 + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  is = Nlat - i + 1
!     n-m even
                  DO np1 = mp1 , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(i,2*m,k)           &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(i,2*m+1,k)         &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
!     n-m odd
                  DO np1 = mp2 , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(is,2*m,k)          &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(is,2*m+1,k)        &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF ( Nlon==L+L-2 ) THEN
!     compute m=l-1, n=l-1,l,...,nlat-1 coefficients
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            DO k = 1 , Nt
               DO i = 1 , Late
                  is = Nlat - i + 1
                  DO np1 = L , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(i,Nlon,k)*Pmn(i,mn)
                  ENDDO
!     n-m  odd
                  lp1 = L + 1
                  DO np1 = lp1 , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(is,Nlon,k)         &
                                & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ELSE
 
!     half sphere
!     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
         nl2 = Nlat/2
         DO k = 1 , Nt
            DO j = 1 , Nlon
               DO i = 1 , nl2
                  G(i,j,k) = Wts(i)*(G(i,j,k)+G(i,j,k))
               ENDDO
!     adjust equator separately if a grid point
               IF ( nl2<Late ) G(Late,j,k) = Wts(Late)*G(Late,j,k)
            ENDDO
         ENDDO
 
!     set m = 0 coefficients first
         mp1 = 1
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         ms = 1
         IF ( Mode==1 ) ms = 2
         DO k = 1 , Nt
            DO i = 1 , Late
               DO np1 = ms , Nlat , 2
                  A(1,np1,k) = A(1,np1,k) + G(i,1,k)*Pmn(i,mml1+np1)
               ENDDO
            ENDDO
         ENDDO
 
!     compute m.ge.1  coefficients next
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            ms = mp1
            IF ( Mode==1 ) ms = mp1 + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  DO np1 = ms , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(i,2*m,k)           &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(i,2*m+1,k)         &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
 
         IF ( Nlon==L+L-2 ) THEN
!     compute n=m=l-1 coefficients last
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
!     set starting n for mode even
            ns = L
!     set starting n for mode odd
            IF ( Mode==1 ) ns = L + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  DO np1 = ns , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(i,Nlon,k)*Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ENDIF
 
      END SUBROUTINE SHAGS1


      SUBROUTINE SHAGSI(Nlat,Nlon,Wshags,Lshags,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , ipmnf , l , l1 , l2 , late , ldw , Ldwork , lp , &
            & Lshags , Lwork , Nlat , Nlon
      REAL Work , Wshags
!     this subroutine must be called before calling shags or shsgs with
!     fixed nlat,nlon. it precomputes the gaussian weights, points
!     and all necessary legendre polys and stores them in wshags.
!     these quantities must be preserved when calling shags or shsgs
!     repeatedly with fixed nlat,nlon.  dwork must be of length at
!     least nlat*(nlat+4) in the routine calling shagsi.  This is
!     not checked.  undetectable errors will result if dwork is
!     smaller than nlat*(nlat+4).
!
      DIMENSION Wshags(Lshags) , Work(Lwork)
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
!     set triangular truncation limit for spherical harmonic basis
      l = MIN0((Nlon+2)/2,Nlat)
!     set equator or nearest point (if excluded) pointer
      late = (Nlat+1)/2
      l1 = l
      l2 = late
!     check permanent work space length
      Ierror = 3
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshags<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
      Ierror = 5
!     check double precision temporary space
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      ldw = Nlat*(Nlat+4)
      CALL SHAGSP(Nlat,Nlon,Wshags,Lshags,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!     set legendre poly pointer in wshags
      ipmnf = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1))         &
            & + Nlon + 16
      CALL SHAGSS1(Nlat,l,late,Wshags,Work,Wshags(ipmnf))
      END SUBROUTINE SHAGSI

      
      SUBROUTINE SHAGSS1(Nlat,L,Late,W,Pmn,Pmnf)
      IMPLICIT NONE
      INTEGER i , j , k , km , L , Late , m , mml1 , mn , mode , mp1 ,  &
            & Nlat , np1
      REAL Pmn , Pmnf , W
      DIMENSION W(1) , Pmn(Nlat,Late,3) , Pmnf(Late,1)
!     compute and store legendre polys for i=1,...,late,m=0,...,l-1
!     and n=m,...,l-1
      DO i = 1 , Nlat
         DO j = 1 , Late
            DO k = 1 , 3
               Pmn(i,j,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
      DO mp1 = 1 , L
         m = mp1 - 1
         mml1 = m*(2*Nlat-m-1)/2
!     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
         mode = 0
         CALL LEGIN(mode,L,Nlat,m,W,Pmn,km)
!     store above in pmnf
         DO np1 = mp1 , Nlat
            mn = mml1 + np1
            DO i = 1 , Late
               Pmnf(i,mn) = Pmn(np1,i,km)
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE SHAGSS1 


      SUBROUTINE SHAGSP(Nlat,Nlon,Wshags,Lshags,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , i6 , i7 , idth , idwts , Ierror ,&
            & iw , l , l1 , l2 , late , Ldwork , Lshags , Nlat , Nlon
      REAL Wshags
      DIMENSION Wshags(Lshags)
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
!     set triangular truncation limit for spherical harmonic basis
      l = MIN0((Nlon+2)/2,Nlat)
!     set equator or nearest point (if excluded) pointer
      late = (Nlat+MOD(Nlat,2))/2
      l1 = l
      l2 = late
      Ierror = 3
!     check permanent work space length
      IF ( Lshags<Nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+Nlon+15 ) RETURN
      Ierror = 4
!     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set pointers
      i1 = 1
      i2 = i1 + Nlat
      i3 = i2 + Nlat*late
      i4 = i3 + Nlat*late
      i5 = i4 + l*(l-1)/2 + (Nlat-l)*(l-1)
      i6 = i5 + l*(l-1)/2 + (Nlat-l)*(l-1)
      i7 = i6 + l*(l-1)/2 + (Nlat-l)*(l-1)
!     set indices in temp work for double precision gaussian wts and pts
      idth = 1
!     idwts = idth+2*nlat
!     iw = idwts+2*nlat
      idwts = idth + Nlat
      iw = idwts + Nlat
      CALL SHAGSP1(Nlat,Nlon,l,late,Wshags(i1),Wshags(i2),Wshags(i3),   &
                 & Wshags(i4),Wshags(i5),Wshags(i6),Wshags(i7),         &
                 & Dwork(idth),Dwork(idwts),Dwork(iw),Ierror)
      IF ( Ierror/=0 ) Ierror = 6
      END SUBROUTINE SHAGSP 

      
      SUBROUTINE SHAGSP1(Nlat,Nlon,L,Late,Wts,P0n,P1n,Abel,Bbel,Cbel,   &
                       & Wfft,Dtheta,Dwts,Work,Ier)
      IMPLICIT NONE
      REAL Abel , Bbel , Cbel , P0n , P1n , Wfft , Wts
      INTEGER i , Ier , imn , IMNDX , INDX , L , Late , lw , m , mlim , &
            & n , Nlat , Nlon , np1
      DIMENSION Wts(Nlat) , P0n(Nlat,Late) , P1n(Nlat,Late) , Abel(1) , &
              & Bbel(1) , Cbel(1) , Wfft(1) , Dtheta(Nlat) , Dwts(Nlat)
      DOUBLE PRECISION pb , Dtheta , Dwts , Work(*)
      INDX(m,n) = (n-1)*(n-2)/2 + m - 1
      IMNDX(m,n) = L*(L-1)/2 + (n-L-1)*(L-1) + m - 1
      CALL HRFFTI(Nlon,Wfft)
 
!     compute double precision gaussian points and weights
!     lw = 4*nlat*(nlat+2)
      lw = Nlat*(Nlat+2)
      CALL GAQD(Nlat,Dtheta,Dwts,Work,lw,Ier)
      IF ( Ier/=0 ) RETURN
 
!     store gaussian weights single precision to save computation
!     in inner loops in analysis
      DO i = 1 , Nlat
         Wts(i) = Dwts(i)
      ENDDO
!     initialize p0n,p1n using double precision dnlfk,dnlft
      DO np1 = 1 , Nlat
         DO i = 1 , Late
            P0n(np1,i) = 0.0
            P1n(np1,i) = 0.0
         ENDDO
      ENDDO
!     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      CALL DNLFK(m,n,Work)
      DO i = 1 , Late
         CALL DNLFT(m,n,Dtheta(i),Work,pb)
         P0n(1,i) = pb
      ENDDO
!     compute p0n,p1n for all theta(i) when n.gt.0
      DO np1 = 2 , Nlat
         n = np1 - 1
         m = 0
         CALL DNLFK(m,n,Work)
         DO i = 1 , Late
            CALL DNLFT(m,n,Dtheta(i),Work,pb)
            P0n(np1,i) = pb
         ENDDO
!     compute m=1 legendre polynomials for all n and theta(i)
         m = 1
         CALL DNLFK(m,n,Work)
         DO i = 1 , Late
            CALL DNLFT(m,n,Dtheta(i),Work,pb)
            P1n(np1,i) = pb
         ENDDO
      ENDDO
!
!     compute and store swarztrauber recursion coefficients
!     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO n = 2 , Nlat
         mlim = MIN0(n,L)
         DO m = 2 , mlim
            imn = INDX(m,n)
            IF ( n>=L ) imn = IMNDX(m,n)
            Abel(imn) = SQRT(FLOAT((2*n+1)*(m+n-2)*(m+n-3))/FLOAT(((2*n-&
                      & 3)*(m+n-1)*(m+n))))
            Bbel(imn) = SQRT(FLOAT((2*n+1)*(n-m-1)*(n-m))/FLOAT(((2*n-3)&
                      & *(m+n-1)*(m+n))))
            Cbel(imn) = SQRT(FLOAT((n-m+1)*(n-m+2))/FLOAT(((n+m-1)*(n+m)&
                      & )))
         ENDDO
      ENDDO
    END SUBROUTINE SHAGSP1

    
    SUBROUTINE DSHAGS(Nlat,Nlon,Mode,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshags,&
                     & Lshags,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Work , Wshags
      INTEGER Idg , Ierror , ifft , ipmn , iw , iwts , Jdg , l , l1 ,   &
            & l2 , lat , late , lp , Lshags , Lwork , Mdab , Mode ,     &
            & Ndab , Nlat , Nlon
      INTEGER Nt
!     subroutine shags performs the spherical harmonic analysis on
!     a gaussian grid on the array(s) in g and returns the coefficients
!     in array(s) a,b. the necessary legendre polynomials are fully
!     stored in this version.
!
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshags(Lshags) , Work(Lwork)
!     check input parameters
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Mode<0 .OR. Mode>2 ) RETURN
!     set m limit for pmn
      l = MIN0((Nlon+2)/2,Nlat)
!     set gaussian point nearest equator pointer
      late = (Nlat+MOD(Nlat,2))/2
!     set number of grid points for analysis/synthesis
      lat = Nlat
      IF ( Mode/=0 ) lat = late
      Ierror = 4
      IF ( Nt<1 ) RETURN
      Ierror = 5
      IF ( Idg<lat ) RETURN
      Ierror = 6
      IF ( Jdg<Nlon ) RETURN
      Ierror = 7
      IF ( Mdab<l ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      l1 = l
      l2 = late
      Ierror = 9
!     check permanent work space length
!
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshags<lp ) RETURN
      Ierror = 10
!     check temporary work space length
      IF ( Mode==0 .AND. Lwork<Nlat*Nlon*(Nt+1) ) RETURN
      IF ( Mode/=0 .AND. Lwork<l2*Nlon*(Nt+1) ) RETURN
      Ierror = 0
!     set starting address for gaussian wts ,fft values,
!     and fully stored legendre polys in wshags
      iwts = 1
      ifft = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1)) + 1
      ipmn = ifft + Nlon + 15
!     set pointer for internal storage of g
      iw = lat*Nlon*Nt + 1
      CALL DSHAGS1(Nlat,Nlon,l,lat,Mode,G,Idg,Jdg,Nt,A,B,Mdab,Ndab,      &
                & Wshags(iwts),Wshags(ifft),Wshags(ipmn),late,Work,     &
                & Work(iw))
    END SUBROUTINE DSHAGS
    
    
    SUBROUTINE DSHAGS1(Nlat,Nlon,L,Lat,Mode,Gs,Idg,Jdg,Nt,A,B,Mdab,    &
                      & Ndab,Wts,Wfft,Pmn,Late,G,Work)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Gs , Pmn , sfn , t1 , t2 , Wfft , Work , Wts
      INTEGER i , Idg , is , j , Jdg , k , L , Lat , Late , lm1 , lp1 , &
            & m , Mdab , mml1 , mn , Mode , mp1 , mp2 , ms , Ndab
      INTEGER nl2 , Nlat , Nlon , np1 , ns , Nt
      DIMENSION Gs(Idg,Jdg,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt) ,    &
              & G(Lat,Nlon,Nt)
      DIMENSION Wfft(1) , Pmn(Late,1) , Wts(Nlat) , Work(1)
!     set gs array internally in shags1
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = Gs(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
!     do fourier transform
      DO k = 1 , Nt
         CALL DHRFFTF(Lat,Nlon,G(1,1,k),Lat,Wfft,Work)
      ENDDO
 
!     scale result
      sfn = 2.0/FLOAT(Nlon)
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = sfn*G(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
!     compute using gaussian quadrature
!     a(n,m) = s (ga(theta,m)*pnm(theta)*sin(theta)*dtheta)
!     b(n,m) = s (gb(theta,m)*pnm(theta)*sin(theta)*dtheta)
!     here ga,gb are the cos(phi),sin(phi) coefficients of
!     the fourier expansion of g(theta,phi) in phi.  as a result
!     of the above fourier transform they are stored in array
!     g as follows:
!     for each theta(i) and k= l-1
!     ga(0),ga(1),gb(1),ga(2),gb(2),...,ga(k-1),gb(k-1),ga(k)
!     correspond to
!     g(i,1),g(i,2),g(i,3),g(i,4),g(i,5),...,g(i,2l-4),g(i,2l-3),g(i,2l-2)
!     whenever 2*l-2 = nlon exactly
!     initialize coefficients to zero
      DO k = 1 , Nt
         DO np1 = 1 , Nlat
            DO mp1 = 1 , L
               A(mp1,np1,k) = 0.0
               B(mp1,np1,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
!     set mp1 limit on b(mp1) calculation
      lm1 = L
      IF ( Nlon==L+L-2 ) lm1 = L - 1
 
      IF ( Mode==0 ) THEN
!     for full sphere (mode=0) and even/odd reduction:
!     overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
!     overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
         nl2 = Nlat/2
         DO k = 1 , Nt
            DO j = 1 , Nlon
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,j,k)
                  t2 = G(is,j,k)
                  G(i,j,k) = Wts(i)*(t1+t2)
                  G(is,j,k) = Wts(i)*(t1-t2)
               ENDDO
!     adjust equator if necessary(nlat odd)
               IF ( MOD(Nlat,2)/=0 ) G(Late,j,k) = Wts(Late)*G(Late,j,k)
            ENDDO
         ENDDO
!     set m = 0 coefficients first
         mp1 = 1
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         DO k = 1 , Nt
            DO i = 1 , Late
               is = Nlat - i + 1
               DO np1 = 1 , Nlat , 2
!     n even
                  A(1,np1,k) = A(1,np1,k) + G(i,1,k)*Pmn(i,mml1+np1)
               ENDDO
               DO np1 = 2 , Nlat , 2
!     n odd
                  A(1,np1,k) = A(1,np1,k) + G(is,1,k)*Pmn(i,mml1+np1)
               ENDDO
            ENDDO
         ENDDO
!     compute m.ge.1  coefficients next
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            mp2 = mp1 + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  is = Nlat - i + 1
!     n-m even
                  DO np1 = mp1 , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(i,2*m,k)           &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(i,2*m+1,k)         &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
!     n-m odd
                  DO np1 = mp2 , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(is,2*m,k)          &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(is,2*m+1,k)        &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF ( Nlon==L+L-2 ) THEN
!     compute m=l-1, n=l-1,l,...,nlat-1 coefficients
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            DO k = 1 , Nt
               DO i = 1 , Late
                  is = Nlat - i + 1
                  DO np1 = L , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(i,Nlon,k)*Pmn(i,mn)
                  ENDDO
!     n-m  odd
                  lp1 = L + 1
                  DO np1 = lp1 , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(is,Nlon,k)         &
                                & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ELSE
 
!     half sphere
!     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1,...,nlate/2
         nl2 = Nlat/2
         DO k = 1 , Nt
            DO j = 1 , Nlon
               DO i = 1 , nl2
                  G(i,j,k) = Wts(i)*(G(i,j,k)+G(i,j,k))
               ENDDO
!     adjust equator separately if a grid point
               IF ( nl2<Late ) G(Late,j,k) = Wts(Late)*G(Late,j,k)
            ENDDO
         ENDDO
 
!     set m = 0 coefficients first
         mp1 = 1
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         ms = 1
         IF ( Mode==1 ) ms = 2
         DO k = 1 , Nt
            DO i = 1 , Late
               DO np1 = ms , Nlat , 2
                  A(1,np1,k) = A(1,np1,k) + G(i,1,k)*Pmn(i,mml1+np1)
               ENDDO
            ENDDO
         ENDDO
 
!     compute m.ge.1  coefficients next
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            ms = mp1
            IF ( Mode==1 ) ms = mp1 + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  DO np1 = ms , Nlat , 2
                     A(mp1,np1,k) = A(mp1,np1,k) + G(i,2*m,k)           &
                                  & *Pmn(i,mml1+np1)
                     B(mp1,np1,k) = B(mp1,np1,k) + G(i,2*m+1,k)         &
                                  & *Pmn(i,mml1+np1)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
 
         IF ( Nlon==L+L-2 ) THEN
!     compute n=m=l-1 coefficients last
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
!     set starting n for mode even
            ns = L
!     set starting n for mode odd
            IF ( Mode==1 ) ns = L + 1
            DO k = 1 , Nt
               DO i = 1 , Late
                  DO np1 = ns , Nlat , 2
                     mn = mml1 + np1
                     A(L,np1,k) = A(L,np1,k) + 0.5*G(i,Nlon,k)*Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ENDIF
 
      END SUBROUTINE DSHAGS1


      SUBROUTINE DSHAGSI(Nlat,Nlon,Wshags,Lshags,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , ipmnf , l , l1 , l2 , late , ldw , Ldwork , lp , &
            & Lshags , Lwork , Nlat , Nlon
      DOUBLE PRECISION Work , Wshags
!     this subroutine must be called before calling shags or shsgs with
!     fixed nlat,nlon. it precomputes the gaussian weights, points
!     and all necessary legendre polys and stores them in wshags.
!     these quantities must be preserved when calling shags or shsgs
!     repeatedly with fixed nlat,nlon.  dwork must be of length at
!     least nlat*(nlat+4) in the routine calling shagsi.  This is
!     not checked.  undetectable errors will result if dwork is
!     smaller than nlat*(nlat+4).
!
      DIMENSION Wshags(Lshags) , Work(Lwork)
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
!     set triangular truncation limit for spherical harmonic basis
      l = MIN0((Nlon+2)/2,Nlat)
!     set equator or nearest point (if excluded) pointer
      late = (Nlat+1)/2
      l1 = l
      l2 = late
!     check permanent work space length
      Ierror = 3
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshags<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
      Ierror = 5
!     check double precision temporary space
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      ldw = Nlat*(Nlat+4)
      CALL DSHAGSP(Nlat,Nlon,Wshags,Lshags,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!     set legendre poly pointer in wshags
      ipmnf = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1))         &
            & + Nlon + 16
      CALL DSHAGSS1(Nlat,l,late,Wshags,Work,Wshags(ipmnf))
      END SUBROUTINE DSHAGSI

      
      SUBROUTINE DSHAGSS1(Nlat,L,Late,W,Pmn,Pmnf)
      IMPLICIT NONE
      INTEGER i , j , k , km , L , Late , m , mml1 , mn , mode , mp1 ,  &
            & Nlat , np1
      DOUBLE PRECISION Pmn , Pmnf , W
      DIMENSION W(1) , Pmn(Nlat,Late,3) , Pmnf(Late,1)
!     compute and store legendre polys for i=1,...,late,m=0,...,l-1
!     and n=m,...,l-1
      DO i = 1 , Nlat
         DO j = 1 , Late
            DO k = 1 , 3
               Pmn(i,j,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
      DO mp1 = 1 , L
         m = mp1 - 1
         mml1 = m*(2*Nlat-m-1)/2
!     compute pmn for n=m,...,nlat-1 and i=1,...,(l+1)/2
         mode = 0
         CALL LEGIN(mode,L,Nlat,m,W,Pmn,km)
!     store above in pmnf
         DO np1 = mp1 , Nlat
            mn = mml1 + np1
            DO i = 1 , Late
               Pmnf(i,mn) = Pmn(np1,i,km)
            ENDDO
         ENDDO
      ENDDO
      END SUBROUTINE DSHAGSS1 


      SUBROUTINE DSHAGSP(Nlat,Nlon,Wshags,Lshags,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , i6 , i7 , idth , idwts , Ierror ,&
            & iw , l , l1 , l2 , late , Ldwork , Lshags , Nlat , Nlon
      DOUBLE PRECISION Wshags
      DIMENSION Wshags(Lshags)
      DOUBLE PRECISION Dwork(Ldwork)
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
!     set triangular truncation limit for spherical harmonic basis
      l = MIN0((Nlon+2)/2,Nlat)
!     set equator or nearest point (if excluded) pointer
      late = (Nlat+MOD(Nlat,2))/2
      l1 = l
      l2 = late
      Ierror = 3
!     check permanent work space length
      IF ( Lshags<Nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+Nlon+15 ) RETURN
      Ierror = 4
!     if (lwork.lt.4*nlat*(nlat+2)+2) return
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set pointers
      i1 = 1
      i2 = i1 + Nlat
      i3 = i2 + Nlat*late
      i4 = i3 + Nlat*late
      i5 = i4 + l*(l-1)/2 + (Nlat-l)*(l-1)
      i6 = i5 + l*(l-1)/2 + (Nlat-l)*(l-1)
      i7 = i6 + l*(l-1)/2 + (Nlat-l)*(l-1)
!     set indices in temp work for double precision gaussian wts and pts
      idth = 1
!     idwts = idth+2*nlat
!     iw = idwts+2*nlat
      idwts = idth + Nlat
      iw = idwts + Nlat
      CALL DSHAGSP1(Nlat,Nlon,l,late,Wshags(i1),Wshags(i2),Wshags(i3),   &
                 & Wshags(i4),Wshags(i5),Wshags(i6),Wshags(i7),         &
                 & Dwork(idth),Dwork(idwts),Dwork(iw),Ierror)
      IF ( Ierror/=0 ) Ierror = 6
      END SUBROUTINE DSHAGSP 

      
      SUBROUTINE DSHAGSP1(Nlat,Nlon,L,Late,Wts,P0n,P1n,Abel,Bbel,Cbel,   &
                       & Wfft,Dtheta,Dwts,Work,Ier)
      IMPLICIT NONE
      DOUBLE PRECISION Abel , Bbel , Cbel , P0n , P1n , Wfft , Wts
      INTEGER i , Ier , imn , IMNDX , INDX , L , Late , lw , m , mlim , &
            & n , Nlat , Nlon , np1
      DIMENSION Wts(Nlat) , P0n(Nlat,Late) , P1n(Nlat,Late) , Abel(1) , &
              & Bbel(1) , Cbel(1) , Wfft(1) , Dtheta(Nlat) , Dwts(Nlat)
      DOUBLE PRECISION pb , Dtheta , Dwts , Work(*)
      INDX(m,n) = (n-1)*(n-2)/2 + m - 1
      IMNDX(m,n) = L*(L-1)/2 + (n-L-1)*(L-1) + m - 1
      CALL DHRFFTI(Nlon,Wfft)
 
!     compute double precision gaussian points and weights
!     lw = 4*nlat*(nlat+2)
      lw = Nlat*(Nlat+2)
      CALL DGAQD(Nlat,Dtheta,Dwts,Work,lw,Ier)
      IF ( Ier/=0 ) RETURN
 
!     store gaussian weights single precision to save computation
!     in inner loops in analysis
      DO i = 1 , Nlat
         Wts(i) = Dwts(i)
      ENDDO
!     initialize p0n,p1n using double precision dnlfk,dnlft
      DO np1 = 1 , Nlat
         DO i = 1 , Late
            P0n(np1,i) = 0.0
            P1n(np1,i) = 0.0
         ENDDO
      ENDDO
!     compute m=n=0 legendre polynomials for all theta(i)
      np1 = 1
      n = 0
      m = 0
      CALL DDNLFK(m,n,Work)
      DO i = 1 , Late
         CALL DDNLFT(m,n,Dtheta(i),Work,pb)
         P0n(1,i) = pb
      ENDDO
!     compute p0n,p1n for all theta(i) when n.gt.0
      DO np1 = 2 , Nlat
         n = np1 - 1
         m = 0
         CALL DDNLFK(m,n,Work)
         DO i = 1 , Late
            CALL DDNLFT(m,n,Dtheta(i),Work,pb)
            P0n(np1,i) = pb
         ENDDO
!     compute m=1 legendre polynomials for all n and theta(i)
         m = 1
         CALL DDNLFK(m,n,Work)
         DO i = 1 , Late
            CALL DDNLFT(m,n,Dtheta(i),Work,pb)
            P1n(np1,i) = pb
         ENDDO
      ENDDO
!
!     compute and store swarztrauber recursion coefficients
!     for 2.le.m.le.n and 2.le.n.le.nlat in abel,bbel,cbel
      DO n = 2 , Nlat
         mlim = MIN0(n,L)
         DO m = 2 , mlim
            imn = INDX(m,n)
            IF ( n>=L ) imn = IMNDX(m,n)
            Abel(imn) = SQRT(FLOAT((2*n+1)*(m+n-2)*(m+n-3))/FLOAT(((2*n-&
                      & 3)*(m+n-1)*(m+n))))
            Bbel(imn) = SQRT(FLOAT((2*n+1)*(n-m-1)*(n-m))/FLOAT(((2*n-3)&
                      & *(m+n-1)*(m+n))))
            Cbel(imn) = SQRT(FLOAT((n-m+1)*(n-m+2))/FLOAT(((n+m-1)*(n+m)&
                      & )))
         ENDDO
      ENDDO
    END SUBROUTINE DSHAGSP1

