!
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file gradges.f
!
!     this file includes documentation and code for
!     subroutine grades         i
!
! ... files which must be loaded with gradges.f
!
!     sphcom.f, hrfft.f, shaes.f,vhses.f
!
!     subroutine grades(nlat,nlon,isym,nt,v,w,idvw,jdvw,a,b,mdab,ndab,
!    +                  wvhses,lvhses,work,lwork,ierror)
!
!     given the scalar spherical harmonic coefficients a and b, precomputed
!     by subroutine shaes for a scalar field sf, subroutine grades computes
!     an irrotational vector field (v,w) such that
!
!           gradient(sf) = (v,w).
!
!     v is the colatitudinal and w is the east longitudinal component
!     of the gradient.  i.e.,
!
!            v(i,j) = d(sf(i,j))/dtheta
!
!     and
!
!            w(i,j) = 1/sint*d(sf(i,j))/dlambda
!
!     at colatitude
!
!            theta(i) = (i-1)*pi/(nlat-1)
!
!     and longitude
!
!            lambda(j) = (j-1)*2*pi/nlon.
!
!     where sint = sin(theta(i)).  required associated legendre polynomials
!     are stored rather than recomputed as they are in subroutine gradec
!
!
!     input parameters
!
!
!     nlat   the number of colatitudes on the full sphere including the
!            poles. for example, nlat = 37 for a five degree grid.
!            nlat determines the grid increment in colatitude as
!            pi/(nlat-1).  if nlat is odd the equator is located at
!            grid point i=(nlat+1)/2. if nlat is even the equator is
!            located half way between points i=nlat/2 and i=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
!            3.  the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!
!     isym   this has the same value as the isym that was input to
!            subroutine shaes to compute the arrays a and b from the
!            scalar field sf.  isym determines whether (v,w) are
!            computed on the full or half sphere as follows:
!
!      = 0
!
!           sf is not symmetric about the equator. in this case
!           the vector field (v,w) is computed on the entire sphere.
!           i.e., in the arrays  v(i,j),w(i,j) for i=1,...,nlat and
!           j=1,...,nlon.
!
!      = 1
!
!           sf is antisymmetric about the equator. in this case w is
!           antisymmetric and v is symmetric about the equator. w
!           and v are computed on the northern hemisphere only.  i.e.,
!           if nlat is odd they are computed for i=1,...,(nlat+1)/2
!           and j=1,...,nlon.  if nlat is even they are computed for
!           i=1,...,nlat/2 and j=1,...,nlon.
!
!      = 2
!
!           sf is symmetric about the equator. in this case w is
!           symmetric and v is antisymmetric about the equator. w
!           and v are computed on the northern hemisphere only.  i.e.,
!           if nlat is odd they are computed for i=1,...,(nlat+1)/2
!           and j=1,...,nlon.  if nlat is even they are computed for
!           i=1,...,nlat/2 and j=1,...,nlon.
!
!
!     nt     nt is the number of scalar and vector fields.  some
!            computational efficiency is obtained for multiple fields.
!            the arrays a,b,v, and w can be three dimensional corresponding
!            to an indexed multiple array sf.  in this case, multiple
!            vector synthesis will be performed to compute each vector
!            field.  the third index for a,b,v, and w is the synthesis
!            index which assumes the values k = 1,...,nt.  for a single
!            synthesis set nt = 1.  the description of the remaining
!            parameters is simplified by assuming that nt=1 or that a,b,v,
!            and w are two dimensional arrays.
!
!     idvw   the first dimension of the arrays v,w as it appears in
!            the program that calls grades. if isym = 0 then idvw
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idvw must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idvw must be at least (nlat+1)/2.
!
!     jdvw   the second dimension of the arrays v,w as it appears in
!            the program that calls grades. jdvw must be at least nlon.
!
!     a,b    two or three dimensional arrays (see input parameter nt)
!            that contain scalar spherical harmonic coefficients
!            of the scalar field array sf as computed by subroutine shaes.
!     ***    a,b must be computed by shaes prior to calling grades.
!
!     mdab   the first dimension of the arrays a and b as it appears in
!            the program that calls grades (and shaes). mdab must be at
!            least min0(nlat,(nlon+2)/2) if nlon is even or at least
!            min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     ndab   the second dimension of the arrays a and b as it appears in
!            the program that calls grades (and shaes). ndab must be at
!            least nlat.
!
!
!   wvhses   an array which must be initialized by subroutine gradesi
!            (or equivalently by subroutine vhsesi).  once initialized,
!            wsav can be used repeatedly by grades as long as nlon
!            and nlat remain unchanged.  wvhses must not be altered
!            between calls of grades.
!
!
!  lvhses    the dimension of the array wvhses as it appears in the
!            program that calls grades. define
!
!               l1 = min0(nlat,nlon/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 lvhses must be greater than or equal to
!
!               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
!
!     work   a work array that does not have to be saved.
!
!     lwork  the dimension of the array work as it appears in the
!            program that calls grades. define
!
!               l1 = min0(nlat,nlon/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
!
!            if isym = 0, lwork must be greater than or equal to
!
!               nlat*((2*nt+1)*nlon+2*l1*nt+1).
!
!            if isym = 1 or 2, lwork must be greater than or equal to
!
!               (2*nt+1)*l2*nlon+nlat*(2*l1*nt+1).
!
!
!     **************************************************************
!
!     output parameters
!
!
!     v,w   two or three dimensional arrays (see input parameter nt) that
!           contain an irrotational vector field such that the gradient of
!           the scalar field sf is (v,w).  w(i,j) is the east longitude
!           component and v(i,j) is the colatitudinal component of velocity
!           at colatitude theta(i) = (i-1)*pi/(nlat-1) and longitude
!           lambda(j) = (j-1)*2*pi/nlon. the indices for v and w are defined
!           at the input parameter isym.  the vorticity of (v,w) is zero.
!           note that any nonzero vector field on the sphere will be
!           multiple valued at the poles [reference swarztrauber].
!
!
!  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 idvw
!           = 6  error in the specification of jdvw
!           = 7  error in the specification of mdab
!           = 8  error in the specification of ndab
!           = 9  error in the specification of lvhses
!           = 10 error in the specification of lwork
! **********************************************************************
!
!
      SUBROUTINE GRADES(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,A,B,Mdab,Ndab,  &
                      & Wvhses,Lvhses,Work,Lwork,Ierror)
      IMPLICIT NONE
!*--GRADES220

      REAL A , B , V , W , Work , Wvhses
      INTEGER ibi , ibr , idv , Idvw , idz , Ierror , imid , is , Isym ,&
            & iwk , Jdvw , lgdmin , liwk , lnl , Lvhses , lwkmin ,      &
            & Lwork , lzimn , Mdab , mmax
      INTEGER mn , Ndab , Nlat , Nlon , Nt

      DIMENSION V(Idvw,Jdvw,Nt) , W(Idvw,Jdvw,Nt)
      DIMENSION A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wvhses(Lvhses) , Work(Lwork)
!
!     check input parameters
!
      Ierror = 1
      IF ( Nlat.LT.3 ) RETURN
      Ierror = 2
      IF ( Nlon.LT.4 ) RETURN
      Ierror = 3
      IF ( Isym.LT.0 .OR. Isym.GT.2 ) RETURN
      Ierror = 4
      IF ( Nt.LT.0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Isym.EQ.0 .AND. Idvw.LT.Nlat) .OR.                          &
         & (Isym.NE.0 .AND. Idvw.LT.imid) ) RETURN
      Ierror = 6
      IF ( Jdvw.LT.Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( Mdab.LT.MIN0(Nlat,(Nlon+2)/2) ) RETURN
      Ierror = 8
      IF ( Ndab.LT.Nlat ) RETURN
      Ierror = 9
!
!     verify minimum saved work space length
!
      idz = (mmax*(Nlat+Nlat-mmax+1))/2
      lzimn = idz*imid
      lgdmin = lzimn + lzimn + Nlon + 15
      IF ( Lvhses.LT.lgdmin ) RETURN
      Ierror = 10
!
!     verify minimum unsaved work space length
!
      mn = mmax*Nlat*Nt
      idv = Nlat
      IF ( Isym.NE.0 ) idv = imid
      lnl = Nt*idv*Nlon
      lwkmin = lnl + lnl + idv*Nlon + 2*mn + Nlat
      IF ( Lwork.LT.lwkmin ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ibr = 1
      ibi = ibr + mn
      is = ibi + mn
      iwk = is + Nlat
      liwk = Lwork - 2*mn - Nlat
      CALL GRADES1(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,Work(ibr),Work(ibi), &
                 & mmax,Work(is),Mdab,Ndab,A,B,Wvhses,Lvhses,Work(iwk), &
                 & liwk,Ierror)
    END SUBROUTINE GRADES

 
    SUBROUTINE GRADES1(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,Br,Bi,Mmax,    &
                       & Sqnn,Mdab,Ndab,A,B,Wvhses,Lvhses,Wk,Lwk,Ierror)
      IMPLICIT NONE

      REAL A , B , Bi , Br , ci , cr , fn , Sqnn , V , W , Wk , Wvhses
      INTEGER Idvw , Ierror , Isym , ityp , Jdvw , k , Lvhses , Lwk ,   &
            & m , Mdab , Mmax , n , Ndab , Nlat , Nlon , Nt

      DIMENSION V(Idvw,Jdvw,Nt) , W(Idvw,Jdvw,Nt)
      DIMENSION Br(Mmax,Nlat,Nt) , Bi(Mmax,Nlat,Nt) , Sqnn(Nlat)
      DIMENSION A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wvhses(Lvhses) , Wk(Lwk)
!
!     preset coefficient multiplyers in vector
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Sqnn(n) = SQRT(fn*(fn+1.))
      ENDDO
!
!     compute multiple vector fields coefficients
!
      DO k = 1 , Nt
!
!     preset br,bi to 0.0
!
         DO n = 1 , Nlat
            DO m = 1 , Mmax
               Br(m,n,k) = 0.0
               Bi(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            Br(1,n,k) = Sqnn(n)*A(1,n,k)
            Bi(1,n,k) = Sqnn(n)*B(1,n,k)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , Mmax
            DO n = m , Nlat
               Br(m,n,k) = Sqnn(n)*A(m,n,k)
               Bi(m,n,k) = Sqnn(n)*B(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     set ityp for irrotational vector synthesis to compute gradient
!
      IF ( Isym.EQ.0 ) THEN
         ityp = 1
      ELSEIF ( Isym.EQ.1 ) THEN
         ityp = 4
      ELSEIF ( Isym.EQ.2 ) THEN
         ityp = 7
      ENDIF
!
!     vector sythesize br,bi into (v,w) (cr,ci are dummy variables)
!
      CALL VHSES(Nlat,Nlon,ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,cr,ci,Mmax,Nlat, &
               & Wvhses,Lvhses,Wk,Lwk,Ierror)
    END SUBROUTINE GRADES1


      SUBROUTINE DGRADES(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,A,B,Mdab,Ndab,  &
                      & Wvhses,Lvhses,Work,Lwork,Ierror)
      IMPLICIT NONE

      DOUBLE PRECISION ::  A , B , V , W , Work , Wvhses
      INTEGER ibi , ibr , idv , Idvw , idz , Ierror , imid , is , Isym ,&
            & iwk , Jdvw , lgdmin , liwk , lnl , Lvhses , lwkmin ,      &
            & Lwork , lzimn , Mdab , mmax
      INTEGER mn , Ndab , Nlat , Nlon , Nt

      DIMENSION V(Idvw,Jdvw,Nt) , W(Idvw,Jdvw,Nt)
      DIMENSION A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wvhses(Lvhses) , Work(Lwork)
!
!     check input parameters
!
      Ierror = 1
      IF ( Nlat.LT.3 ) RETURN
      Ierror = 2
      IF ( Nlon.LT.4 ) RETURN
      Ierror = 3
      IF ( Isym.LT.0 .OR. Isym.GT.2 ) RETURN
      Ierror = 4
      IF ( Nt.LT.0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Isym.EQ.0 .AND. Idvw.LT.Nlat) .OR.                          &
         & (Isym.NE.0 .AND. Idvw.LT.imid) ) RETURN
      Ierror = 6
      IF ( Jdvw.LT.Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+1)/2)
      IF ( Mdab.LT.MIN0(Nlat,(Nlon+2)/2) ) RETURN
      Ierror = 8
      IF ( Ndab.LT.Nlat ) RETURN
      Ierror = 9
!
!     verify minimum saved work space length
!
      idz = (mmax*(Nlat+Nlat-mmax+1))/2
      lzimn = idz*imid
      lgdmin = lzimn + lzimn + Nlon + 15
      IF ( Lvhses.LT.lgdmin ) RETURN
      Ierror = 10
!
!     verify minimum unsaved work space length
!
      mn = mmax*Nlat*Nt
      idv = Nlat
      IF ( Isym.NE.0 ) idv = imid
      lnl = Nt*idv*Nlon
      lwkmin = lnl + lnl + idv*Nlon + 2*mn + Nlat
      IF ( Lwork.LT.lwkmin ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ibr = 1
      ibi = ibr + mn
      is = ibi + mn
      iwk = is + Nlat
      liwk = Lwork - 2*mn - Nlat
      CALL DGRADES1(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,Work(ibr),Work(ibi), &
                 & mmax,Work(is),Mdab,Ndab,A,B,Wvhses,Lvhses,Work(iwk), &
                 & liwk,Ierror)
      END SUBROUTINE DGRADES

 
      SUBROUTINE DGRADES1(Nlat,Nlon,Isym,Nt,V,W,Idvw,Jdvw,Br,Bi,Mmax,    &
                       & Sqnn,Mdab,Ndab,A,B,Wvhses,Lvhses,Wk,Lwk,Ierror)
      IMPLICIT NONE

      DOUBLE PRECISION  A , B , Bi , Br , ci , cr , fn , Sqnn , V , W , Wk , Wvhses
      INTEGER Idvw , Ierror , Isym , ityp , Jdvw , k , Lvhses , Lwk ,   &
            & m , Mdab , Mmax , n , Ndab , Nlat , Nlon , Nt

      DIMENSION V(Idvw,Jdvw,Nt) , W(Idvw,Jdvw,Nt)
      DIMENSION Br(Mmax,Nlat,Nt) , Bi(Mmax,Nlat,Nt) , Sqnn(Nlat)
      DIMENSION A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wvhses(Lvhses) , Wk(Lwk)
!
!     preset coefficient multiplyers in vector
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Sqnn(n) = SQRT(fn*(fn+1.))
      ENDDO
!
!     compute multiple vector fields coefficients
!
      DO k = 1 , Nt
!
!     preset br,bi to 0.0
!
         DO n = 1 , Nlat
            DO m = 1 , Mmax
               Br(m,n,k) = 0.0
               Bi(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            Br(1,n,k) = Sqnn(n)*A(1,n,k)
            Bi(1,n,k) = Sqnn(n)*B(1,n,k)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , Mmax
            DO n = m , Nlat
               Br(m,n,k) = Sqnn(n)*A(m,n,k)
               Bi(m,n,k) = Sqnn(n)*B(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     set ityp for irrotational vector synthesis to compute gradient
!
      IF ( Isym.EQ.0 ) THEN
         ityp = 1
      ELSEIF ( Isym.EQ.1 ) THEN
         ityp = 4
      ELSEIF ( Isym.EQ.2 ) THEN
         ityp = 7
      ENDIF
!
!     vector sythesize br,bi into (v,w) (cr,ci are dummy variables)
!
      CALL DVHSES(Nlat,Nlon,ityp,Nt,V,W,Idvw,Jdvw,Br,Bi,cr,ci,Mmax,Nlat, &
               & Wvhses,Lvhses,Wk,Lwk,Ierror)
    END SUBROUTINE DGRADES1


