!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file shigs.f
!
!     this file contains code and documentation for subroutine shigs
!
! ... files which must be loaded with shigs.f
!
!     sphcom.f, hrfft.f, gaqd.f
!
!     3/6/98
!
! *** shigs is functionally the same as shagsi or shsgsi.  It
!     it included in spherepack3.0 because legacy codes, using
!     the older version of spherepack, call shigs to initialize
!     the saved work space wshigs for either shags or shsgs
!     Its arguments are identical to those of shagsi or shsgsi.
!
! ****************************************************************
!
!     subroutine shigs(nlat,nlon,wshigs,lshigs,work,lwork,dwork,ldwork,
!    +                 ierror)
!
!     subroutine shigs initializes the array wshigs which can then
!     be used repeatedly by subroutines shags,shsgs. it precomputes
!     and stores in wshigs 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.
!
!     wshigs an array which must be initialized by subroutine shigs .
!            once initialized, wshigs can be used repeatedly by shigs
!            as long as nlat and nlon remain unchanged.  wshigs must
!            not be altered between calls of shigs.
!
!     lshigs the dimension of the array wshigs as it appears in the
!            program that calls shigs. 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 lshigs 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 shigs. lwork must be at least
!            4*nlat*(nlat+2)+2 in the routine calling shigs
!
!     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 SHIGS(Nlat,Nlon,Wshigs,Lshigs,Work,Lwork,Dwork,Ldwork, &
                     & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , ipmnf , l , l1 , l2 , late , Ldwork , lp ,       &
            & Lshigs , Lwork , Nlat , Nlon
      REAL Work , Wshigs
!
!     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 wshigs.
!     these quantities must be preserved when calling shsgs or shags
!     repeatedly with fixed nlat,nlon.
!
      DIMENSION Wshigs(Lshigs) , 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 ( Lshigs<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
!     check temp double precision space
      Ierror = 5
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      CALL SHIGSP(Nlat,Nlon,Wshigs,Lshigs,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!     set legendre poly pointer in wshigs
      ipmnf = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1))         &
            & + Nlon + 16
      CALL SHIGSS1(Nlat,l,late,Wshigs,Work,Wshigs(ipmnf))
    END SUBROUTINE SHIGS

      
      SUBROUTINE SHIGSS1(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 SHIGSS1


      SUBROUTINE SHIGSP(Nlat,Nlon,Wshigs,Lshigs,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , i6 , i7 , idth , idwts , Ierror ,&
            & iw , l , l1 , l2 , late , Ldwork , Lshigs , Nlat , Nlon
      REAL Wshigs
      DIMENSION Wshigs(Lshigs)
      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 ( Lshigs<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 SHIGSP1(Nlat,Nlon,l,late,Wshigs(i1),Wshigs(i2),Wshigs(i3),   &
                 & Wshigs(i4),Wshigs(i5),Wshigs(i6),Wshigs(i7),         &
                 & Dwork(idth),Dwork(idwts),Dwork(iw),Ierror)
      IF ( Ierror/=0 ) Ierror = 5
      END SUBROUTINE SHIGSP

      
      SUBROUTINE SHIGSP1(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 SHIGSP1

      SUBROUTINE DSHIGS(Nlat,Nlon,Wshigs,Lshigs,Work,Lwork,Dwork,Ldwork, &
                     & Ierror)
      IMPLICIT NONE
      INTEGER Ierror , ipmnf , l , l1 , l2 , late , Ldwork , lp ,       &
            & Lshigs , Lwork , Nlat , Nlon
      DOUBLE PRECISION Work , Wshigs
!
!     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 wshigs.
!     these quantities must be preserved when calling shsgs or shags
!     repeatedly with fixed nlat,nlon.
!
      DIMENSION Wshigs(Lshigs) , 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 ( Lshigs<lp ) RETURN
      Ierror = 4
!     check temporary work space
      IF ( Lwork<4*Nlat*(Nlat+2)+2 ) RETURN
!     check temp double precision space
      Ierror = 5
      IF ( Ldwork<Nlat*(Nlat+4) ) RETURN
      Ierror = 0
!     set preliminary quantites needed to compute and store legendre polys
      CALL DSHIGSP(Nlat,Nlon,Wshigs,Lshigs,Dwork,Ldwork,Ierror)
      IF ( Ierror/=0 ) RETURN
!     set legendre poly pointer in wshigs
      ipmnf = Nlat + 2*Nlat*late + 3*(l*(l-1)/2+(Nlat-l)*(l-1))         &
            & + Nlon + 16
      CALL DSHIGSS1(Nlat,l,late,Wshigs,Work,Wshigs(ipmnf))
    END SUBROUTINE DSHIGS

      
      SUBROUTINE DSHIGSS1(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 DLEGIN(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 DSHIGSS1


      SUBROUTINE DSHIGSP(Nlat,Nlon,Wshigs,Lshigs,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
      INTEGER i1 , i2 , i3 , i4 , i5 , i6 , i7 , idth , idwts , Ierror ,&
            & iw , l , l1 , l2 , late , Ldwork , Lshigs , Nlat , Nlon
      DOUBLE PRECISION Wshigs
      DIMENSION Wshigs(Lshigs)
      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 ( Lshigs<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 DSHIGSP1(Nlat,Nlon,l,late,Wshigs(i1),Wshigs(i2),Wshigs(i3),   &
                 & Wshigs(i4),Wshigs(i5),Wshigs(i6),Wshigs(i7),         &
                 & Dwork(idth),Dwork(idwts),Dwork(iw),Ierror)
      IF ( Ierror/=0 ) Ierror = 5
      END SUBROUTINE DSHIGSP

      
      SUBROUTINE DSHIGSP1(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 DSHIGSP1
