!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file igrades.f
!
!     this file includes documentation and code for
!     subroutine igrades         i
!
! ... files which must be loaded with igradec.f
!
!     sphcom.f, hrfft.f, shses.f,vhaes.f
!
!     subroutine igrades(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
!    +                   wshses,lshses,work,lwork,ierror)
!
!     let br,bi,cr,ci be the vector spherical harmonic coefficients
!     precomputed by vhaes for a vector field (v,w).  let (v',w') be
!     the irrotational component of (v,w) (i.e., (v',w') is generated
!     by assuming cr,ci are zero and synthesizing br,bi with vhses).
!     then subroutine igrades computes a scalar field sf such that
!
!            gradient(sf) = (v',w').
!
!     i.e.,
!
!            v'(i,j) = d(sf(i,j))/dtheta          (colatitudinal component of
!                                                 the gradient)
!     and
!
!            w'(i,j) = 1/sint*d(sf(i,j))/dlambda  (east longitudinal component
!                                                 of the gradient)
!
!     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 igradec.
!
!     note:  for an irrotational vector field (v,w), subroutine igrades
!     computes a scalar field whose gradient is (v,w).  in ay case,
!     subroutine igrades "inverts" the gradient subroutine grades.
!
!
!     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   a parameter which determines whether the scalar field sf is
!            computed on the full or half sphere as follows:
!
!      = 0
!
!            the symmetries/antsymmetries described in isym=1,2 below
!            do not exist in (v,w) about the equator.  in this case sf
!            is neither symmetric nor antisymmetric about the equator.
!            sf is computed on the entire sphere.  i.e., in the array
!            sf(i,j) for i=1,...,nlat and  j=1,...,nlon
!
!      = 1
!
!            w is antisymmetric and v is symmetric about the equator.
!            in this case sf is antisymmetyric about the equator and
!            is computed for the northern hemisphere only.  i.e.,
!            if nlat is odd sf is computed in the array sf(i,j) for
!            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
!            sf is computed in the array sf(i,j) for i=1,...,nlat/2
!            and j=1,...,nlon.
!
!      = 2
!
!            w is symmetric and v is antisymmetric about the equator.
!            in this case sf is symmetyric about the equator and
!            is computed for the northern hemisphere only.  i.e.,
!            if nlat is odd sf is computed in the array sf(i,j) for
!            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
!            sf is computed in the array sf(i,j) 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 br,bi, and sf can be three dimensional corresponding
!            to an indexed multiple vector field (v,w).  in this case,
!            multiple scalar synthesis will be performed to compute each
!            scalar field.  the third index for br,bi, and sf 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 br,bi,
!            and sf are two dimensional arrays.
!
!     isf    the first dimension of the array sf as it appears in
!            the program that calls igrades. if isym = 0 then isf
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then isf must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then isf must be at least (nlat+1)/2.
!
!     jsf    the second dimension of the array sf as it appears in
!            the program that calls igrades. jsf must be at least nlon.
!
!     br,bi  two or three dimensional arrays (see input parameter nt)
!            that contain vector spherical harmonic coefficients
!            of the vector field (v,w) as computed by subroutine vhaes.
!     ***    br,bi must be computed by vhaes prior to calling igrades.
!
!     mdb    the first dimension of the arrays br and bi as it appears in
!            the program that calls igrades (and vhaes). mdb must be at
!            least min0(nlat,nlon/2) if nlon is even or at least
!            min0(nlat,(nlon+1)/2) if nlon is odd.
!
!     ndb    the second dimension of the arrays br and bi as it appears in
!            the program that calls igrades (and vhaes). ndb must be at
!            least nlat.
!
!
!  wshses    an array which must be initialized by subroutine igradesi
!            (or equivalently by subroutine shsesi).  once initialized,
!            wshses can be used repeatedly by igrades as long as nlon
!            and nlat remain unchanged.  wshses must not be altered
!            between calls of igrades.
!
!
!  lshses    the dimension of the array wshses as it appears in the
!            program that calls igrades. 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 lshses 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 igrades. define
!
!               l2 = nlat/2                    if nlat is even or
!               l2 = (nlat+1)/2                if nlat is odd
!               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
!               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
!
!            if isym = 0 lwork must be greater than or equal to
!
!               nlat*((nt+1)*nlon+2*nt*l1+1)
!
!            if isym > 0 lwork must be greater than or equal to
!
!               (nt+1)*l2*nlon+nlat*(2*nt*l1+1)
!
!
!
!     **************************************************************
!
!     output parameters
!
!
!     sf    a two or three dimensional array (see input parameter nt) that
!           contain a scalar field whose gradient is the irrotational
!           component of the vector field (v,w).  the vector spherical
!           harmonic coefficients br,bi were precomputed by subroutine
!           vhaes.  sf(i,j) is given at the gaussian colatitude theta(i)
!           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
!           are defined at input parameter isym.
!
!
!  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 isf
!           = 6  error in the specification of jsf
!           = 7  error in the specification of mdb
!           = 8  error in the specification of ndb
!           = 9  error in the specification of lshses
!           = 10 error in the specification of lwork
!
! **********************************************************************
!
      SUBROUTINE IGRADES(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,Br,Bi,Mdb,Ndb,    &
                       & Wshses,Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL Bi , Br , Sf , Work , Wshses
      INTEGER ia , ib , Ierror , imid , is , Isf , Isym , iwk , Jsf ,   &
            & liwk , lpimn , ls , Lshses , lwkmin , Lwork , mab , Mdb , &
            & mmax , mn , Ndb
      INTEGER Nlat , nln , Nlon , Nt
      DIMENSION Sf(Isf,Jsf,Nt)
      DIMENSION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt)
      DIMENSION Wshses(Lshses) , Work(Lwork)
!
!     check input parameters
!
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Isym<0 .OR. Isym>2 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Isym==0 .AND. Isf<Nlat) .OR. (Isym/=0 .AND. Isf<imid) )     &
         & RETURN
      Ierror = 6
      IF ( Jsf<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+2)/2)
      IF ( Mdb<MIN0(Nlat,(Nlon+1)/2) ) RETURN
      Ierror = 8
      IF ( Ndb<Nlat ) RETURN
      Ierror = 9
!
!     verify saved work space length
!
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 10
!
!     set minimum and verify unsaved work space
!
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
!
!     set first dimension for a,b (as requried by shses)
!
      mab = MIN0(Nlat,Nlon/2+1)
      mn = mab*Nlat*Nt
      lwkmin = nln + ls*Nlon + 2*mn + Nlat
      IF ( Lwork<lwkmin ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + Nlat
      liwk = Lwork - 2*mn - Nlat
      CALL IGRDES1(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,Work(ia),Work(ib),mab,  &
                 & Work(is),Mdb,Ndb,Br,Bi,Wshses,Lshses,Work(iwk),liwk, &
                 & Ierror)
    END SUBROUTINE IGRADES

    
    SUBROUTINE IGRDES1(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,A,B,Mab,Sqnn,Mdb, &
                       & Ndb,Br,Bi,Wshses,Lshses,Wk,Lwk,Ierror)
      IMPLICIT NONE
      REAL A , B , Bi , Br , fn , Sf , Sqnn , Wk , Wshses
      INTEGER Ierror , Isf , Isym , Jsf , k , Lshses , Lwk , m , Mab ,  &
            & Mdb , mmax , n , Ndb , Nlat , Nlon , Nt
      DIMENSION Sf(Isf,Jsf,Nt)
      DIMENSION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt) , Sqnn(Nlat)
      DIMENSION A(Mab,Nlat,Nt) , B(Mab,Nlat,Nt)
      DIMENSION Wshses(Lshses) , Wk(Lwk)
!
!     preset coefficient multiplyers in vector
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Sqnn(n) = 1.0/SQRT(fn*(fn+1.))
      ENDDO
!
!     set upper limit for vector m subscript
!
      mmax = MIN0(Nlat,(Nlon+1)/2)
!
!     compute multiple scalar field coefficients
!
      DO k = 1 , Nt
!
!     preset to 0.0
!
         DO n = 1 , Nlat
            DO m = 1 , Mab
               A(m,n,k) = 0.0
               B(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            A(1,n,k) = Br(1,n,k)*Sqnn(n)
            B(1,n,k) = Bi(1,n,k)*Sqnn(n)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = Sqnn(n)*Br(m,n,k)
               B(m,n,k) = Sqnn(n)*Bi(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     scalar sythesize a,b into sf
!
      CALL SHSES(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
      END SUBROUTINE IGRDES1

      
      SUBROUTINE DIGRADES(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,Br,Bi,Mdb,Ndb,    &
                       & Wshses,Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION Bi , Br , Sf , Work , Wshses
      INTEGER ia , ib , Ierror , imid , is , Isf , Isym , iwk , Jsf ,   &
            & liwk , lpimn , ls , Lshses , lwkmin , Lwork , mab , Mdb , &
            & mmax , mn , Ndb
      INTEGER Nlat , nln , Nlon , Nt
      DIMENSION Sf(Isf,Jsf,Nt)
      DIMENSION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt)
      DIMENSION Wshses(Lshses) , Work(Lwork)
!
!     check input parameters
!
      Ierror = 1
      IF ( Nlat<3 ) RETURN
      Ierror = 2
      IF ( Nlon<4 ) RETURN
      Ierror = 3
      IF ( Isym<0 .OR. Isym>2 ) RETURN
      Ierror = 4
      IF ( Nt<0 ) RETURN
      Ierror = 5
      imid = (Nlat+1)/2
      IF ( (Isym==0 .AND. Isf<Nlat) .OR. (Isym/=0 .AND. Isf<imid) )     &
         & RETURN
      Ierror = 6
      IF ( Jsf<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,(Nlon+2)/2)
      IF ( Mdb<MIN0(Nlat,(Nlon+1)/2) ) RETURN
      Ierror = 8
      IF ( Ndb<Nlat ) RETURN
      Ierror = 9
!
!     verify saved work space length
!
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
      Ierror = 10
!
!     set minimum and verify unsaved work space
!
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
!
!     set first dimension for a,b (as requried by shses)
!
      mab = MIN0(Nlat,Nlon/2+1)
      mn = mab*Nlat*Nt
      lwkmin = nln + ls*Nlon + 2*mn + Nlat
      IF ( Lwork<lwkmin ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + Nlat
      liwk = Lwork - 2*mn - Nlat
      CALL DIGRDES1(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,Work(ia),Work(ib),mab,  &
                 & Work(is),Mdb,Ndb,Br,Bi,Wshses,Lshses,Work(iwk),liwk, &
                 & Ierror)
    END SUBROUTINE DIGRADES

    
    SUBROUTINE DIGRDES1(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,A,B,Mab,Sqnn,Mdb, &
                       & Ndb,Br,Bi,Wshses,Lshses,Wk,Lwk,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , Bi , Br , fn , Sf , Sqnn , Wk , Wshses
      INTEGER Ierror , Isf , Isym , Jsf , k , Lshses , Lwk , m , Mab ,  &
            & Mdb , mmax , n , Ndb , Nlat , Nlon , Nt
      DIMENSION Sf(Isf,Jsf,Nt)
      DIMENSION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt) , Sqnn(Nlat)
      DIMENSION A(Mab,Nlat,Nt) , B(Mab,Nlat,Nt)
      DIMENSION Wshses(Lshses) , Wk(Lwk)
!
!     preset coefficient multiplyers in vector
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Sqnn(n) = 1.0/SQRT(fn*(fn+1.))
      ENDDO
!
!     set upper limit for vector m subscript
!
      mmax = MIN0(Nlat,(Nlon+1)/2)
!
!     compute multiple scalar field coefficients
!
      DO k = 1 , Nt
!
!     preset to 0.0
!
         DO n = 1 , Nlat
            DO m = 1 , Mab
               A(m,n,k) = 0.0
               B(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            A(1,n,k) = Br(1,n,k)*Sqnn(n)
            B(1,n,k) = Bi(1,n,k)*Sqnn(n)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = Sqnn(n)*Br(m,n,k)
               B(m,n,k) = Sqnn(n)*Bi(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     scalar sythesize a,b into sf
!
      CALL DSHSES(Nlat,Nlon,Isym,Nt,Sf,Isf,Jsf,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
      END SUBROUTINE DIGRDES1
