!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by ucar                 .
!  .                                                             .
!  .       university corporation for atmospheric research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         spherepack3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file gaqd.f
!
!     this file includes documentation and code for subrooutine gaqd.
!
! ... required files
!
!     none
!
!     subroutine gaqd(nlat,theta,wts,dwork,ldwork,ierror)
!
!     subroutine gaqd computes the nlat gaussian colatitudes and weights
!     in double precision. the colatitudes are in radians and lie in the
!     in the interval (0,pi).
!
!     input parameters
!
!     nlat    the number of gaussian colatitudes in the interval (0,pi)
!             (between the two poles).  nlat must be greater than zero.
!
!     dwork   a temporary work space
!
!     ldwork  the length of the work space  in the routine calling gaqd
!             ldwork must be at least nlat*(nlat+2).
!
!     output parameters
!
!     theta   a double precision vector of length nlat containing the
!             nlat gaussian colatitudes on the sphere in increasing radians
!             in the interval (o,pi).
!
!     wts     a double precision vector of length nlat containing the
!             nlat gaussian weights.
!
!     ierror = 0 no errors
!            = 1 if ldwork.lt.nlat*(nlat+2)
!            = 2 if nlat.le.0
!            = 3 if unable to compute gaussian points
!                (failure in in eigenvalue routine)
!
!  *****************************************************************
      SUBROUTINE GAQD(Nlat,Theta,Wts,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
!*--GAQD60

      INTEGER i1 , i2 , i3 , Ierror , Ldwork , n , Nlat
      DOUBLE PRECISION Theta(Nlat) , Wts(Nlat) , Dwork(Ldwork) , x
      n = Nlat
      Ierror = 1
!     check work space length
      IF ( Ldwork<n*(n+2) ) RETURN
      Ierror = 2
      IF ( n<=0 ) RETURN
      Ierror = 0
      IF ( n>2 ) THEN
!
!     partition dwork space for double precision eigenvalue(vector computation)
!
         i1 = 1
         i2 = i1 + n
         i3 = i2 + n
         CALL GAQD1(n,Theta,Wts,Dwork(i1),Dwork(i2),Dwork(i3),Ierror)
         IF ( Ierror/=0 ) THEN
            Ierror = 3
            RETURN
         ENDIF
         RETURN
      ELSEIF ( n==1 ) THEN
         Wts(1) = 2.0D0
         Theta(1) = DACOS(0.0D0)
      ELSEIF ( n==2 ) THEN
!     compute weights and points analytically when n=2
         Wts(1) = 1.0D0
         Wts(2) = 1.0D0
         x = DSQRT(1.0D0/3.0D0)
         Theta(1) = DACOS(x)
         Theta(2) = DACOS(-x)
         RETURN
      ENDIF
      END SUBROUTINE GAQD
      
      SUBROUTINE DGAQD(Nlat,Theta,Wts,Dwork,Ldwork,Ierror)
      IMPLICIT NONE
!*--GAQD60
      INTEGER i1 , i2 , i3 , Ierror , Ldwork , n , Nlat
      DOUBLE PRECISION Theta(Nlat) , Wts(Nlat) , Dwork(Ldwork) , x

      ! Already a double precision routine
      CALL GAQD(Nlat,Theta,Wts,Dwork,Ldwork,Ierror)
      

      END SUBROUTINE DGAQD


      SUBROUTINE GAQD1(N,Theta,Wts,W,E,Z,Ier)
      IMPLICIT NONE
!*--GAQD1101
      INTEGER i , Ier , j , matz , N , n2
      DOUBLE PRECISION, DIMENSION(N) :: Theta, Wts, W, E      
      DOUBLE PRECISION, DIMENSION(N,N) ::  Z
      DOUBLE PRECISION :: temp
      
!     set symmetric tridiagnonal matrix subdiagonal and diagonal
!     coefficients for matrix coming from coefficients in the
!     recursion formula for legendre polynomials
!     a(n)*p(n-1)+b(n)*p(n)+c(n)*p(n+1) = 0.
      W(1) = 0.D0
      E(1) = 0.D0
      DO j = 2 , N
         E(j) = (j-1.D0)/DSQRT((2.D0*j-1.D0)*(2.D0*j-3.D0))
         W(j) = 0.D0
      ENDDO
!
!     compute eigenvalues and eigenvectors
!
      matz = 1
      CALL DRST(N,N,W,E,matz,Z,Ier)
      IF ( Ier/=0 ) RETURN
!
!     compute gaussian weights and points
!
      DO j = 1 , N
         Theta(j) = DACOS(W(j))
!
!     set gaussian weights as 1st components of eigenvectors squared
!
         Wts(j) = 2.0D0*Z(1,j)**2
      ENDDO
!
!     reverse order of gaussian points to be
!     monotonic increasing in radians
!
      n2 = N/2
      DO i = 1 , n2
         temp = Theta(i)
         Theta(i) = Theta(N-i+1)
         Theta(N-i+1) = temp
      ENDDO
      END

      SUBROUTINE DRST(Nm,N,W,E,Matz,Z,Ierr)
      IMPLICIT NONE
!*--DRST147
!     drst is a double precision modification of rst off eispack
!     to be used  to compute gaussian points and weights
 
!
      INTEGER i , j , N , Nm , Ierr , Matz
      DOUBLE PRECISION W(N) , E(N) , Z(Nm,N)
 
!
!     .......... find both eigenvalues and eigenvectors ..........
      DO i = 1 , N
!
         DO j = 1 , N
            Z(j,i) = 0.0D0
         ENDDO
!
         Z(i,i) = 1.0D0
      ENDDO
!
      CALL DINTQL(Nm,N,W,E,Z,Ierr)
      END

      SUBROUTINE DINTQL(Nm,N,D,E,Z,Ierr)
      IMPLICIT NONE
!*--DINTQL171

      INTEGER mdo , nm1

!     dintql is a double precision modification of intql2 off
!     eispack to be used by gaqd in spherepack for computing
!     gaussian weights and points
!
      INTEGER i , j , k , l , m , N , ii , Nm , mml , Ierr
      DOUBLE PRECISION D(N) , E(N) , Z(Nm,N)
      DOUBLE PRECISION b , c , f , g , p , r , s , tst1 , tst2 , DPYTHA
      Ierr = 0
      IF ( N/=1 ) THEN
!
         DO i = 2 , N
            E(i-1) = E(i)
         ENDDO
!
         E(N) = 0.0D0
!
         DO l = 1 , N
            j = 0
!     .......... look for small sub-diagonal element ..........
!
 20         nm1 = N - 1
            IF ( l<=nm1 ) THEN
               DO mdo = l , nm1
                  m = mdo
                  tst1 = DABS(D(m)) + DABS(D(m+1))
                  tst2 = tst1 + DABS(E(m))
                  IF ( tst2==tst1 ) GOTO 40
               ENDDO
            ENDIF
            m = N
!
 40         p = D(l)
            IF ( m/=l ) THEN
               IF ( j==30 ) GOTO 100
               j = j + 1
!     .......... form shift ..........
               g = (D(l+1)-p)/(2.0D0*E(l))
               r = DPYTHA(g,1.0D0)
               g = D(m) - p + E(l)/(g+SIGN(r,g))
               s = 1.0D0
               c = 1.0D0
               p = 0.0D0
               mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
               DO ii = 1 , mml
                  i = m - ii
                  f = s*E(i)
                  b = c*E(i)
                  r = DPYTHA(f,g)
                  E(i+1) = r
                  IF ( r==0.0D0 ) GOTO 50
                  s = f/r
                  c = g/r
                  g = D(i+1) - p
                  r = (D(i)-g)*s + 2.0D0*c*b
                  p = s*r
                  D(i+1) = g + p
                  g = c*r - b
!     .......... form vector ..........
                  DO k = 1 , N
                     f = Z(k,i+1)
                     Z(k,i+1) = s*Z(k,i) + c*f
                     Z(k,i) = c*Z(k,i) - s*f
                  ENDDO
!
               ENDDO
!
               D(l) = D(l) - p
               E(l) = g
               E(m) = 0.0D0
               GOTO 20
!     .......... recover from underflow ..........
 50            D(i+1) = D(i+1) - p
               E(m) = 0.0D0
               GOTO 20
            ENDIF
         ENDDO
!     .......... order eigenvalues and eigenvectors ..........
         DO ii = 2 , N
            i = ii - 1
            k = i
            p = D(i)
!
            DO j = ii , N
               IF ( D(j)<p ) THEN
                  k = j
                  p = D(j)
               ENDIF
            ENDDO
!
            IF ( k/=i ) THEN
               D(k) = D(i)
               D(i) = p
!
               DO j = 1 , N
                  p = Z(j,i)
                  Z(j,i) = Z(j,k)
                  Z(j,k) = p
               ENDDO
            ENDIF
!
!
         ENDDO
      ENDIF
      GOTO 99999
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
 100  Ierr = l
99999 END

      DOUBLE PRECISION FUNCTION DPYTHA(A,B)
      IMPLICIT NONE
!*--DPYTHA287
      DOUBLE PRECISION A , B
!     dpytha is a double precision modification of pythag off eispack
!     for use by dimtql
 
!
!     finds sqrt(a**2+b**2) without overflow or destructive underflow
!
      DOUBLE PRECISION p , r , s , t , u
      p = DABS(A)
      IF ( DABS(B)>=DABS(A) ) p = DABS(B)
      IF ( p==0.0D0 ) THEN
         DPYTHA = p
      ELSE
         r = (DABS(A)/p)**2
         IF ( DABS(B)<DABS(A) ) r = (DABS(B)/p)**2
 50      t = 4.0D0 + r
         IF ( t==4.0D0 ) THEN
            DPYTHA = p
         ELSE
            s = r/t
            u = 1.0D0 + 2.0D0*s
            p = u*p
            r = (s/u)**2*r
            GOTO 50
         ENDIF
      ENDIF
      END
