!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file shsgs.f
!
!     this file contains code and documentation for subroutines
!     shsgs and shsgsi
!
! ... files which must be loaded with shsgs.f
 
!     sphcom.f, hrfft.f, gaqd.f
!
!     subroutine shsgs(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
!    1                    wshsgs,lshsgs,work,lwork,ierror)
!
!     subroutine shsgs performs the spherical harmonic synthesis
!     on the arrays a and b and stores the result in the array g.
!     the synthesis is performed on an equally spaced longitude grid
!     and a gaussian colatitude grid.  the associated legendre functions
!     are stored rather than recomputed as they are in subroutine
!     shsgc.  the synthesis is described below at output parameter
!     g.
!
!
!     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 synthesis
!                 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 synthesis
!                 is performed on the northern hemisphere only.  i.e.
!                 if nlat is odd the synthesis is performed on the
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the synthesis 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 synthesis is
!                 performed on the northern hemisphere only.  i.e.
!                 if nlat is odd the synthesis is performed on the
!                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
!                 if nlat is even the synthesis is performed on the
!                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
!
!     nt     the number of syntheses.  in the program that calls shsgs,
!            the arrays g,a and b can be three dimensional in which
!            case multiple synthesis will be performed.  the third
!            index is the synthesis index which assumes the values
!            k=1,...,nt.  for a single synthesis 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.
!
!     idg    the first dimension of the array g as it appears in the
!            program that calls shagc. 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 shagc. jdg must be at least nlon.
!
!     a,b    two or three dimensional arrays (see the input parameter
!            nt) that contain the coefficients in the spherical harmonic
!            expansion of g(i,j) given below at the definition of the
!            output parameter g.  a(m,n) and b(m,n) are defined for
!            indices m=1,...,mmax and n=m,...,nlat where mmax is the
!            maximum (plus one) longitudinal wave number given by
!            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
!            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     mdab   the first dimension of the arrays a and b as it appears
!            in the program that calls shsgs. 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 shsgs. ndab must be at least nlat
!
!     wshsgs an array which must be initialized by subroutine shsgsi.
!            once initialized, wshsgs can be used repeatedly by shsgs
!            as long as nlat and nlon remain unchanged.  wshsgs must
!            not be altered between calls of shsgs.
!
!     lshsgs the dimension of the array wshsgs as it appears in the
!            program that calls shsgs. 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 lshsgs must be at least
!
!            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/2+nlon+15
!
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls shsgs. 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
!
!     g      a two or three dimensional array (see input parameter nt)
!            that contains the discrete function which is synthesized.
!            g(i,j) contains the value of the function at the gaussian
!            colatitude point theta(i) and longitude point
!            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
!            above at the input parameter isym.  for isym=0, g(i,j)
!            is given by the the equations listed below.  symmetric
!            versions are used when isym is greater than zero.
!
!     the normalized associated legendre functions are given by
!
!     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)
!
!     define the maximum (plus one) longitudinal wave number
!     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
!          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     then g(i,j) = the sum from n=0 to n=nlat-1 of
!
!                   .5*pbar(0,n,theta(i))*a(1,n+1)
!
!              plus the sum from m=1 to m=mmax-1 of
!
!                   the sum from n=m to n=nlat-1 of
!
!              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
!                                    -b(m+1,n+1)*sin(m*phi(j)))
!
!
!     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 lshsgs
!            = 10 error in the specification of lwork
!
!
! ****************************************************************
!
!     subroutine shsgsi(nlat,nlon,wshsgs,lshsgs,work,lwork,dwork,ldwork,
!    +                  ierror)
!
!     subroutine shsgsi initializes the array wshsgs which can then
!     be used repeatedly by subroutines shsgs. it precomputes
!     and stores in wshsgs 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.
!
!     wshsgs an array which must be initialized by subroutine shsgsi.
!            once initialized, wshsgs can be used repeatedly by shsgs
!            as long as nlat and nlon remain unchanged.  wshsgs must
!            not be altered between calls of shsgs.
!
!     lshsgs the dimension of the array wshsgs as it appears in the
!            program that calls shsgs. 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 lshsgs 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 shsgsi. lwork must be at least
!            4*nlat*(nlat+2)+2 in the routine calling shsgsi
!
!     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
!
!     wshsgs an array which must be initialized before calling shsgs or
!            once initialized, wshsgs can be used repeatedly by shsgs or
!            as long as nlat and nlon remain unchanged.  wshsgs must not
!            altered between calls of shsgs.
!
!     ierror = 0  no errors
!            = 1  error in the specification of nlat
!            = 2  error in the specification of nlon
!            = 3  error in the specification of lshsgs
!            = 4  error in the specification of lwork
!            = 5  error in the specification of ldwork
!            = 5  failure in gaqd to compute gaussian points
!                 (due to failure in eigenvalue routine)
!
!
      SUBROUTINE SHSGS(Nlat,Nlon,Mode,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshsgs,&
                     & Lshsgs,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL A , B , G , Work , Wshsgs
      INTEGER Idg , Ierror , ifft , ipmn , iw , Jdg , l , l1 , l2 ,     &
            & lat , late , lp , Lshsgs , Lwork , Mdab , Mode , Ndab ,   &
            & Nlat , Nlon , Nt
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshsgs(Lshsgs) , 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
      Ierror = 4
      IF ( Nt<1 ) RETURN
!     set limit on m subscript
      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 = 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 ( Lshsgs<lp ) RETURN
!     check temporary work space length
      Ierror = 10
      IF ( Mode==0 .AND. Lwork<Nlat*Nlon*(Nt+1) ) RETURN
      IF ( Mode/=0 .AND. Lwork<l2*Nlon*(Nt+1) ) RETURN
      Ierror = 0
!     starting address for fft values and legendre polys in wshsgs
      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 SHSGS1(Nlat,Nlon,l,lat,Mode,G,Idg,Jdg,Nt,A,B,Mdab,Ndab,      &
                & Wshsgs(ifft),Wshsgs(ipmn),late,Work,Work(iw))
    END SUBROUTINE SHSGS

      
    SUBROUTINE SHSGS1(Nlat,Nlon,L,Lat,Mode,Gs,Idg,Jdg,Nt,A,B,Mdab,    &
                      & Ndab,Wfft,Pmn,Late,G,Work)
      IMPLICIT NONE
      REAL A , B , G , Gs , Pmn , t1 , t2 , t3 , t4 , Wfft , Work
      INTEGER i , Idg , is , j , Jdg , k , L , Lat , Late , lm1 , lp1 , &
            & m , Mdab , meo , mml1 , mn , Mode , mp1 , mp2 , ms
      INTEGER Ndab , nl2 , Nlat , Nlon , np1 , ns , Nt
      DIMENSION Gs(Idg,Jdg,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wfft(1) , Pmn(Late,1) , G(Lat,Nlon,Nt) , Work(1)
 
!     reconstruct fourier coefficients in g on gaussian grid
!     using coefficients in a,b
 
!     initialize to zero
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
 
      lm1 = L
      IF ( Nlon==L+L-2 ) lm1 = L - 1
      IF ( Mode==0 ) THEN
!     set first column in g
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         DO k = 1 , Nt
!     n even
            DO np1 = 1 , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , Late
                  G(i,1,k) = G(i,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
!     n odd
            nl2 = Nlat/2
            DO np1 = 2 , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  G(is,1,k) = G(is,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
         ENDDO
 
!     restore m=0 coefficients from odd/even
         DO k = 1 , Nt
            DO i = 1 , nl2
               is = Nlat - i + 1
               t1 = G(i,1,k)
               t3 = G(is,1,k)
               G(i,1,k) = t1 + t3
               G(is,1,k) = t1 - t3
            ENDDO
         ENDDO
 
!     sweep interior columns of g
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            mp2 = m + 2
            DO k = 1 , Nt
!     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,2*m+1
!     for i=1,...,late
               DO np1 = mp1 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,2*m,k) = G(i,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(i,2*m+1,k) = G(i,2*m+1,k) + B(mp1,np1,k)         &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
 
!     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
!     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
               DO np1 = mp2 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , nl2
                     is = Nlat - i + 1
                     G(is,2*m,k) = G(is,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(is,2*m+1,k) = G(is,2*m+1,k) + B(mp1,np1,k)       &
                                   & *Pmn(i,mn)
                  ENDDO
               ENDDO
 
!     now set fourier coefficients using even-odd reduction above
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,2*m,k)
                  t2 = G(i,2*m+1,k)
                  t3 = G(is,2*m,k)
                  t4 = G(is,2*m+1,k)
                  G(i,2*m,k) = t1 + t3
                  G(i,2*m+1,k) = t2 + t4
                  G(is,2*m,k) = t1 - t3
                  G(is,2*m+1,k) = t2 - t4
               ENDDO
 
            ENDDO
         ENDDO
 
!     set last column (using a only) if necessary
         IF ( Nlon==L+L-2 ) THEN
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            DO k = 1 , Nt
!     n-m even
               DO np1 = L , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,Nlon,k) = G(i,Nlon,k) + 2.0*A(L,np1,k)         &
                                 & *Pmn(i,mn)
 
                  ENDDO
               ENDDO
               lp1 = L + 1
!     n-m odd
               DO np1 = lp1 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , nl2
                     is = Nlat - i + 1
                     G(is,Nlon,k) = G(is,Nlon,k) + 2.0*A(L,np1,k)       &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,Nlon,k)
                  t3 = G(is,Nlon,k)
                  G(i,Nlon,k) = t1 + t3
                  G(is,Nlon,k) = t1 - t3
               ENDDO
            ENDDO
         ENDIF
 
      ELSE
!     half sphere (mode.ne.0)
!     set first column in g
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         meo = 1
         IF ( Mode==1 ) meo = 2
         ms = m + meo
         DO k = 1 , Nt
            DO np1 = ms , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , Late
                  G(i,1,k) = G(i,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
         ENDDO
 
!     sweep interior columns of g
 
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            ms = m + meo
            DO k = 1 , Nt
               DO np1 = ms , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,2*m,k) = G(i,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(i,2*m+1,k) = G(i,2*m+1,k) + B(mp1,np1,k)         &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
 
         IF ( Nlon==L+L-2 ) THEN
!     set last column
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            ns = L
            IF ( Mode==1 ) ns = L + 1
            DO k = 1 , Nt
               DO np1 = ns , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,Nlon,k) = G(i,Nlon,k) + 2.0*A(L,np1,k)         &
                                 & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ENDIF
 
 
!     do inverse fourier transform
      DO k = 1 , Nt
         CALL HRFFTB(Lat,Nlon,G(1,1,k),Lat,Wfft,Work)
      ENDDO
!     scale output in gs
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               Gs(i,j,k) = 0.5*G(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
      END SUBROUTINE SHSGS1


      SUBROUTINE SHSGSI(Nlat,Nlon,Wshsgs,Lshsgs,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , l , l1 , l2 , late , ldw , Ldwork , lp , Lshsgs ,&
            & Lwork , Nlat , Nlon
      REAL Work , Wshsgs
!
!     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 wshsgs.
!     these quantities must be preserved when calling shsgs
!     repeatedly with fixed nlat,nlon.
!
      DIMENSION Wshsgs(Lshsgs) , 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 ( Lshsgs<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
      Ierror = 5
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      ldw = Nlat*(Nlat+4)
      CALL SHSGSP(Nlat,Nlon,Wshsgs,Lshsgs,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!
!     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 wshsgs.
!     these quantities must be preserved when calling shsgs
!     repeatedly with fixed nlat,nlon.
!
!     set triangular truncation limit for spherical harmonic basis
!     set equator or nearest point (if excluded) pointer
!     check permanent work space length
!     check temporary work space
!     set preliminary quantites needed to compute and store legendre polys
!     set legendre poly pointer in wshsgs
      END SUBROUTINE SHSGSI


      
      SUBROUTINE DSHSGS(Nlat,Nlon,Mode,Nt,G,Idg,Jdg,A,B,Mdab,Ndab,Wshsgs,&
                     & Lshsgs,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Work , Wshsgs
      INTEGER Idg , Ierror , ifft , ipmn , iw , Jdg , l , l1 , l2 ,     &
            & lat , late , lp , Lshsgs , Lwork , Mdab , Mode , Ndab ,   &
            & Nlat , Nlon , Nt
      DIMENSION G(Idg,Jdg,1) , A(Mdab,Ndab,1) , B(Mdab,Ndab,1) ,        &
              & Wshsgs(Lshsgs) , 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
      Ierror = 4
      IF ( Nt<1 ) RETURN
!     set limit on m subscript
      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 = 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 ( Lshsgs<lp ) RETURN
!     check temporary work space length
      Ierror = 10
      IF ( Mode==0 .AND. Lwork<Nlat*Nlon*(Nt+1) ) RETURN
      IF ( Mode/=0 .AND. Lwork<l2*Nlon*(Nt+1) ) RETURN
      Ierror = 0
!     starting address for fft values and legendre polys in wshsgs
      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 DSHSGS1(Nlat,Nlon,l,lat,Mode,G,Idg,Jdg,Nt,A,B,Mdab,Ndab,      &
                & Wshsgs(ifft),Wshsgs(ipmn),late,Work,Work(iw))
    END SUBROUTINE DSHSGS

      
    SUBROUTINE DSHSGS1(Nlat,Nlon,L,Lat,Mode,Gs,Idg,Jdg,Nt,A,B,Mdab,    &
                      & Ndab,Wfft,Pmn,Late,G,Work)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , G , Gs , Pmn , t1 , t2 , t3 , t4 , Wfft , Work
      INTEGER i , Idg , is , j , Jdg , k , L , Lat , Late , lm1 , lp1 , &
            & m , Mdab , meo , mml1 , mn , Mode , mp1 , mp2 , ms
      INTEGER Ndab , nl2 , Nlat , Nlon , np1 , ns , Nt
      DIMENSION Gs(Idg,Jdg,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wfft(1) , Pmn(Late,1) , G(Lat,Nlon,Nt) , Work(1)
 
!     reconstruct fourier coefficients in g on gaussian grid
!     using coefficients in a,b
 
!     initialize to zero
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               G(i,j,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
 
      lm1 = L
      IF ( Nlon==L+L-2 ) lm1 = L - 1
      IF ( Mode==0 ) THEN
!     set first column in g
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         DO k = 1 , Nt
!     n even
            DO np1 = 1 , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , Late
                  G(i,1,k) = G(i,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
!     n odd
            nl2 = Nlat/2
            DO np1 = 2 , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  G(is,1,k) = G(is,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
         ENDDO
 
!     restore m=0 coefficients from odd/even
         DO k = 1 , Nt
            DO i = 1 , nl2
               is = Nlat - i + 1
               t1 = G(i,1,k)
               t3 = G(is,1,k)
               G(i,1,k) = t1 + t3
               G(is,1,k) = t1 - t3
            ENDDO
         ENDDO
 
!     sweep interior columns of g
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            mp2 = m + 2
            DO k = 1 , Nt
!     for n-m even store (g(i,p,k)+g(nlat-i+1,p,k))/2 in g(i,p,k) p=2*m,2*m+1
!     for i=1,...,late
               DO np1 = mp1 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,2*m,k) = G(i,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(i,2*m+1,k) = G(i,2*m+1,k) + B(mp1,np1,k)         &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
 
!     for n-m odd store g(i,p,k)-g(nlat-i+1,p,k) in g(nlat-i+1,p,k)
!     for i=1,...,nlat/2 (p=2*m,p=2*m+1)
               DO np1 = mp2 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , nl2
                     is = Nlat - i + 1
                     G(is,2*m,k) = G(is,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(is,2*m+1,k) = G(is,2*m+1,k) + B(mp1,np1,k)       &
                                   & *Pmn(i,mn)
                  ENDDO
               ENDDO
 
!     now set fourier coefficients using even-odd reduction above
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,2*m,k)
                  t2 = G(i,2*m+1,k)
                  t3 = G(is,2*m,k)
                  t4 = G(is,2*m+1,k)
                  G(i,2*m,k) = t1 + t3
                  G(i,2*m+1,k) = t2 + t4
                  G(is,2*m,k) = t1 - t3
                  G(is,2*m+1,k) = t2 - t4
               ENDDO
 
            ENDDO
         ENDDO
 
!     set last column (using a only) if necessary
         IF ( Nlon==L+L-2 ) THEN
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            DO k = 1 , Nt
!     n-m even
               DO np1 = L , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,Nlon,k) = G(i,Nlon,k) + 2.0*A(L,np1,k)         &
                                 & *Pmn(i,mn)
 
                  ENDDO
               ENDDO
               lp1 = L + 1
!     n-m odd
               DO np1 = lp1 , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , nl2
                     is = Nlat - i + 1
                     G(is,Nlon,k) = G(is,Nlon,k) + 2.0*A(L,np1,k)       &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
               DO i = 1 , nl2
                  is = Nlat - i + 1
                  t1 = G(i,Nlon,k)
                  t3 = G(is,Nlon,k)
                  G(i,Nlon,k) = t1 + t3
                  G(is,Nlon,k) = t1 - t3
               ENDDO
            ENDDO
         ENDIF
 
      ELSE
!     half sphere (mode.ne.0)
!     set first column in g
         m = 0
         mml1 = m*(2*Nlat-m-1)/2
         meo = 1
         IF ( Mode==1 ) meo = 2
         ms = m + meo
         DO k = 1 , Nt
            DO np1 = ms , Nlat , 2
               mn = mml1 + np1
               DO i = 1 , Late
                  G(i,1,k) = G(i,1,k) + A(1,np1,k)*Pmn(i,mn)
               ENDDO
            ENDDO
         ENDDO
 
!     sweep interior columns of g
 
         DO mp1 = 2 , lm1
            m = mp1 - 1
            mml1 = m*(2*Nlat-m-1)/2
            ms = m + meo
            DO k = 1 , Nt
               DO np1 = ms , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,2*m,k) = G(i,2*m,k) + A(mp1,np1,k)*Pmn(i,mn)
                     G(i,2*m+1,k) = G(i,2*m+1,k) + B(mp1,np1,k)         &
                                  & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
 
         IF ( Nlon==L+L-2 ) THEN
!     set last column
            m = L - 1
            mml1 = m*(2*Nlat-m-1)/2
            ns = L
            IF ( Mode==1 ) ns = L + 1
            DO k = 1 , Nt
               DO np1 = ns , Nlat , 2
                  mn = mml1 + np1
                  DO i = 1 , Late
                     G(i,Nlon,k) = G(i,Nlon,k) + 2.0*A(L,np1,k)         &
                                 & *Pmn(i,mn)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
 
      ENDIF
 
 
!     do inverse fourier transform
      DO k = 1 , Nt
         CALL DHRFFTB(Lat,Nlon,G(1,1,k),Lat,Wfft,Work)
      ENDDO
!     scale output in gs
      DO k = 1 , Nt
         DO j = 1 , Nlon
            DO i = 1 , Lat
               Gs(i,j,k) = 0.5*G(i,j,k)
            ENDDO
         ENDDO
      ENDDO
 
      END SUBROUTINE DSHSGS1


      SUBROUTINE DSHSGSI(Nlat,Nlon,Wshsgs,Lshsgs,Work,Lwork,Dwork,Ldwork,&
                      & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , l , l1 , l2 , late , ldw , Ldwork , lp , Lshsgs ,&
            & Lwork , Nlat , Nlon
      DOUBLE PRECISION Work , Wshsgs
!
!     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 wshsgs.
!     these quantities must be preserved when calling shsgs
!     repeatedly with fixed nlat,nlon.
!
      DIMENSION Wshsgs(Lshsgs) , 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 ( Lshsgs<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
      Ierror = 5
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      ldw = Nlat*(Nlat+4)
      CALL DSHSGSP(Nlat,Nlon,Wshsgs,Lshsgs,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!
!     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 wshsgs.
!     these quantities must be preserved when calling shsgs
!     repeatedly with fixed nlat,nlon.
!
!     set triangular truncation limit for spherical harmonic basis
!     set equator or nearest point (if excluded) pointer
!     check permanent work space length
!     check temporary work space
!     set preliminary quantites needed to compute and store legendre polys
!     set legendre poly pointer in wshsgs
      END SUBROUTINE DSHSGSI

      SUBROUTINE DSHSGSP(NLAT,NLON,WSHSGS,LSHSGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHSGS
      DIMENSION WSHSGS(LSHSGS)
!*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.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 (LSHSGS.LT.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.LT.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 DSHSGSP1(NLAT,NLON,L,LATE,WSHSGS(I1),WSHSGS(I2),WSHSGS(I3), &
           WSHSGS(I4),WSHSGS(I5),WSHSGS(I6),WSHSGS(I7), &
           DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 6
      RETURN
    END SUBROUTINE DSHSGSP
    
    SUBROUTINE DSHSGSP1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL, &
      WFFT,DTHETA,DWTS,WORK,IER)
      DOUBLE PRECISION WTS
      DOUBLE PRECISION P0N
      DOUBLE PRECISION P1N
      DOUBLE PRECISION ABEL
      DOUBLE PRECISION BBEL
      DOUBLE PRECISION CBEL
      DOUBLE PRECISION WFFT
      DOUBLE PRECISION FN
      DOUBLE PRECISION FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1), &
           CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
!*PT*WARNING* Already double-precision
      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 = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN

!     store gaussian weights single precision to save computation
!     in inner loops in analysis
      DO  I = 1,NLAT
         WTS(I) = DWTS(I)
      END DO

!     initialize p0n,p1n using double precision dnlfk,dnlft
      DO  NP1 = 1,NLAT
         DO  I = 1,LATE
            P0N(NP1,I) = 0.0D0
            P1N(NP1,I) = 0.0D0
         END DO
      END DO
          
!     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
       END DO
!     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DDNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
!     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DDNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DDNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
!
!     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
                 FN = DBLE(N)
                 MLIM = MIN0(N,L)
                 DO  M = 2,MLIM
                    FM = DBLE(M)
                    IMN = INDX(M,N)
                    IF (N.GE.L) IMN = IMNDX(M,N)
                    ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/ &
                         (((2*FN-3)* (FM+FN-1)* (FM+FN))))
                    BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/ &
                         (((2*FN-3)* (FM+FN-1)* (FM+FN))))
                    CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/ &
                         (((FN+FM-1)* (FN+FM))))
                 END DO
              END DO
      RETURN
      END SUBROUTINE DSHSGSP1

      SUBROUTINE SHSGSP(NLAT,NLON,WSHSGS,LSHSGS,DWORK,LDWORK,IERROR)
      REAL WSHSGS
      DIMENSION WSHSGS(LSHSGS)
!*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.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 (LSHSGS.LT.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.LT.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 SHSGSP1(NLAT,NLON,L,LATE,WSHSGS(I1),WSHSGS(I2),WSHSGS(I3), &
           WSHSGS(I4),WSHSGS(I5),WSHSGS(I6),WSHSGS(I7), &
           DWORK(IDTH),DWORK(IDWTS),DWORK(IW),IERROR)
      IF (IERROR.NE.0) IERROR = 6
      RETURN
    END SUBROUTINE SHSGSP
    
    SUBROUTINE SHSGSP1(NLAT,NLON,L,LATE,WTS,P0N,P1N,ABEL,BBEL,CBEL, &
      WFFT,DTHETA,DWTS,WORK,IER)
      REAL WTS
      REAL P0N
      REAL P1N
      REAL ABEL
      REAL BBEL
      REAL CBEL
      REAL WFFT
      REAL FN
      REAL FM
      DIMENSION WTS(NLAT),P0N(NLAT,LATE),P1N(NLAT,LATE),ABEL(1),BBEL(1), &
           CBEL(1),WFFT(1),DTHETA(NLAT),DWTS(NLAT)
!*PT*WARNING* Already double-precision
      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 = NLAT* (NLAT+2)
      CALL GAQD(NLAT,DTHETA,DWTS,WORK,LW,IER)
      IF (IER.NE.0) RETURN

!     store gaussian weights single precision to save computation
!     in inner loops in analysis
      DO  I = 1,NLAT
         WTS(I) = DWTS(I)
      END DO

!     initialize p0n,p1n using double precision dnlfk,dnlft
      DO  NP1 = 1,NLAT
         DO  I = 1,LATE
            P0N(NP1,I) = 0.0D0
            P1N(NP1,I) = 0.0D0
         END DO
      END DO
          
!     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
       END DO
!     compute p0n,p1n for all theta(i) when n.gt.0
      DO 104 NP1 = 2,NLAT
          N = NP1 - 1
          M = 0
          CALL DNLFK(M,N,WORK)
          DO 105 I = 1,LATE
              CALL DNLFT(M,N,DTHETA(I),WORK,PB)
              P0N(NP1,I) = PB
  105     CONTINUE
!     compute m=1 legendre polynomials for all n and theta(i)
          M = 1
          CALL DNLFK(M,N,WORK)
          DO 106 I = 1,LATE
              CALL DNLFT(M,N,DTHETA(I),WORK,PB)
              P1N(NP1,I) = PB
  106     CONTINUE
  104 CONTINUE
!
!     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
                 FN = DBLE(N)
                 MLIM = MIN0(N,L)
                 DO  M = 2,MLIM
                    FM = DBLE(M)
                    IMN = INDX(M,N)
                    IF (N.GE.L) IMN = IMNDX(M,N)
                    ABEL(IMN) = SQRT(((2*FN+1)* (FM+FN-2)* (FM+FN-3))/ &
                         (((2*FN-3)* (FM+FN-1)* (FM+FN))))
                    BBEL(IMN) = SQRT(((2*FN+1)* (FN-FM-1)* (FN-FM))/ &
                         (((2*FN-3)* (FM+FN-1)* (FM+FN))))
                    CBEL(IMN) = SQRT(((FN-FM+1)* (FN-FM+2))/ &
                         (((FN+FM-1)* (FN+FM))))
                 END DO
              END DO
      RETURN
      END SUBROUTINE SHSGSP1
