!
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
! ... file sfvpes.f
!
!     this file includes documentation and code for
!     subroutine sfvpes          i
!
! ... files which must be loaded with sfvpes.f
!
!     sphcom.f, hrfft.f, vhaes.f, shses.f
!
!
!     subroutine sfvpes(nlat,nlon,isym,nt,sf,vp,idv,jdv,br,bi,cr,ci,
!    +                   mdb,ndb,wshses,lshses,work,lwork,ierror)
!
!     given the vector spherical harmonic coefficients br,bi,cr,ci,
!     computed by subroutine vhaes for a vector field (v,w), sfvpes
!     computes a scalar stream function sf and scalar velocity potential
!     vp for (v,w).  (v,w) is expressed in terms of sf and vp by the
!     helmholtz relations (in mathematical spherical coordinates):
!
!          v = -1/sint*d(vp)/dlambda + d(st)/dtheta
!
!          w =  1/sint*d(st)/dlambda + d(vp)/dtheta
!
!     where sint = sin(theta).  w is the east longitudinal and v
!     is the colatitudinal component of the vector field from which
!     br,bi,cr,ci were precomputed.  required associated legendre
!     polynomials are stored rather than recomputed as they are in
!     subroutine sfvpec. sf(i,j) and vp(i,j) are given at colatitude
!
!            theta(i) = (i-1)*pi/(nlat-1)
!
!     and east longitude
!
!            lambda(j) = (j-1)*2*pi/nlon
!
!     on the sphere.
!
!
!     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 stream function and
!            velocity potential are 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
!            and vp are not necessarily symmetric or antisymmetric about
!            the equator.  sf and vp are computed on the entire sphere.
!            i.e., in arrays sf(i,j),vp(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 symmetric and vp antisymmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i,j),vp(i,j) are computed
!            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
!            even then sf(i,j),vp(i,j) are computed 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 antisymmetric and vp symmetric about
!            the equator and are computed for the northern hemisphere
!            only.  i.e., if nlat is odd the sf(i,j),vp(i,j) are computed
!            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
!            even then sf(i,j),vp(i,j) 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.
!            can be three dimensional corresponding to an indexed multiple
!            vector field.  in this case multiple scalar synthesis will
!            be performed to compute sf,vp for each field.  the
!            third index 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 all the arrays are two dimensional.
!
!     idv    the first dimension of the arrays sf,vp as it appears in
!            the program that calls sfvpes. if isym = 0 then idv
!            must be at least nlat.  if isym = 1 or 2 and nlat is
!            even then idv must be at least nlat/2. if isym = 1 or 2
!            and nlat is odd then idv must be at least (nlat+1)/2.
!
!     jdv    the second dimension of the arrays sf,vp as it appears in
!            the program that calls sfvpes. jdv must be at least nlon.
!
!     br,bi, two or three dimensional arrays (see input parameter nt)
!     cr,ci  that contain vector spherical harmonic coefficients
!            of the vector field (v,w) as computed by subroutine vhaec.
!
!     mdb    the first dimension of the arrays br,bi,cr,ci as it
!            appears in the program that calls sfvpes. 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,bi,cr,ci as it
!            appears in the program that calls sfvpes. ndb must be at
!            least nlat.
!
!     wshses an array which must be initialized by subroutine shsesi.
!            once initialized, wshses can be used repeatedly by sfvpes
!            as long as nlon and nlat remain unchanged.  wshses must
!            not bel altered between calls of sfvpes.
!
!
!     lshses the dimension of the array wshses as it appears in the
!            program that calls sfrvpes. 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 at least
!
!               (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 sfvpes. 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
!
!            if isym is zero then lwork must be at least
!
!               nlat*((nt+1)*nlon + 2*l2*nt+1)
!
!            if isym is nonzero then lwork must be at least
!
!               l2*((nt+1)*nlon + 2*nlat*nt) + nlat
!
!     **************************************************************
!
!     output parameters
!
!    sf,vp  two or three dimensional arrays (see input parameter nt)
!           that contains the stream function and velocity potential
!           of the vector field (v,w) whose coefficients br,bi,cr,ci
!           where computed by subroutine vhaec.  sf(i,j),vp(i,j)
!           are given at the colatitude point
!
!                theta(i) = (i-1)*pi/(nlat-1)
!
!           and longitude point
!
!                lambda(j) = (j-1)*2*pi/nlon
!
!           the index ranges are defined above at the 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 idv
!           = 6  error in the specification of jdv
!           = 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 SFVPES(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,Mdb,&
                      & Ndb,Wshses,Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      INTEGER Nlat , Nlon , Isym , Nt , Idv , Jdv , Mdb , Ndb , Lshses ,&
            & Lwork , Ierror
      REAL Sf(Idv,Jdv,Nt) , Vp(Idv,Jdv,Nt)
      REAL Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt)
      REAL Cr(Mdb,Ndb,Nt) , Ci(Mdb,Ndb,Nt)
      REAL Wshses(Lshses) , Work(Lwork)
      INTEGER imid , mmax , ls , mab , mn , ia , ib , is , lwk , iwk
      INTEGER lpimn
!
!     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. Idv<Nlat) .OR. (Isym>0 .AND. Idv<imid) )      &
         & RETURN
      Ierror = 6
      IF ( Jdv<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 (same as shses)
!
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
!
!     verify unsaved work space (add to what shec requires)
!
      Ierror = 10
      ls = Nlat
      IF ( Isym>0 ) ls = imid
!
!     set first dimension for a,b (as requried by shses)
!
      mab = MIN0(Nlat,Nlon/2+1)
      mn = mab*Nlat*Nt
      IF ( Lwork<ls*(Nt+1)*Nlon+Nlat*(2*imid+1) ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL SFVPES1(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,Mdb,Ndb, &
                 & Work(ia),Work(ib),mab,Work(is),Wshses,Lshses,        &
                 & Work(iwk),lwk,Ierror)
      END SUBROUTINE SFVPES

      
      SUBROUTINE SFVPES1(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,   &
                       & Mdb,Ndb,A,B,Mab,Fnn,Wshses,Lshses,Wk,Lwk,      &
                       & Ierror)
      IMPLICIT NONE

      INTEGER Nlat , Nlon , Isym , Nt , Idv , Jdv , Mdb , Ndb , Mab ,   &
            & Lshses , Lwk , Ierror
      REAL Sf(Idv,Jdv,Nt) , Vp(Idv,Jdv,Nt)
      REAL Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt) , Cr(Mdb,Ndb,Nt) ,           &
         & Ci(Mdb,Ndb,Nt)
      REAL A(Mab,Nlat,Nt) , B(Mab,Nlat,Nt)
      REAL Wshses(Lshses) , Wk(Lwk) , Fnn(Nlat)
      INTEGER n , m , mmax , k
!
!     set coefficient multiplyers
!
      DO n = 2 , Nlat
         Fnn(n) = 1.0/SQRT(FLOAT(n*(n-1)))
      ENDDO
      mmax = MIN0(Nlat,(Nlon+1)/2)
!
!     compute sf scalar coefficients from cr,ci
!
      DO k = 1 , Nt
         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) = -Fnn(n)*Cr(1,n,k)
            B(1,n,k) = -Fnn(n)*Ci(1,n,k)
         ENDDO
!
!     compute m>0 coefficients using vector spherepack value for mmax
!
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = -Fnn(n)*Cr(m,n,k)
               B(m,n,k) = -Fnn(n)*Ci(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize a,b into st
!
      CALL SHSES(Nlat,Nlon,Isym,Nt,Sf,Idv,Jdv,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
!
!    set coefficients for vp from br,bi
!
      DO k = 1 , Nt
         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) = Fnn(n)*Br(1,n,k)
            B(1,n,k) = Fnn(n)*Bi(1,n,k)
         ENDDO
!
!     compute m>0 coefficients using vector spherepack value for mmax
!
         mmax = MIN0(Nlat,(Nlon+1)/2)
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = Fnn(n)*Br(m,n,k)
               B(m,n,k) = Fnn(n)*Bi(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize a,b into vp
!
      CALL SHSES(Nlat,Nlon,Isym,Nt,Vp,Idv,Jdv,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
      END SUBROUTINE SFVPES1


      SUBROUTINE DSFVPES(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,Mdb,&
                      & Ndb,Wshses,Lshses,Work,Lwork,Ierror)
      IMPLICIT NONE
      INTEGER Nlat , Nlon , Isym , Nt , Idv , Jdv , Mdb , Ndb , Lshses ,&
            & Lwork , Ierror
      DOUBLE PRECISION Sf(Idv,Jdv,Nt) , Vp(Idv,Jdv,Nt)
      DOUBLE PRECISION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt)
      DOUBLE PRECISION Cr(Mdb,Ndb,Nt) , Ci(Mdb,Ndb,Nt)
      DOUBLE PRECISION Wshses(Lshses) , Work(Lwork)
      INTEGER imid , mmax , ls , mab , mn , ia , ib , is , lwk , iwk
      INTEGER lpimn
!
!     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. Idv<Nlat) .OR. (Isym>0 .AND. Idv<imid) )      &
         & RETURN
      Ierror = 6
      IF ( Jdv<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 (same as shses)
!
      imid = (Nlat+1)/2
      lpimn = (imid*mmax*(Nlat+Nlat-mmax+1))/2
      IF ( Lshses<lpimn+Nlon+15 ) RETURN
!
!     verify unsaved work space (add to what shec requires)
!
      Ierror = 10
      ls = Nlat
      IF ( Isym>0 ) ls = imid
!
!     set first dimension for a,b (as requried by shses)
!
      mab = MIN0(Nlat,Nlon/2+1)
      mn = mab*Nlat*Nt
      IF ( Lwork<ls*(Nt+1)*Nlon+Nlat*(2*imid+1) ) RETURN
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL DSFVPES1(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,Mdb,Ndb, &
                 & Work(ia),Work(ib),mab,Work(is),Wshses,Lshses,        &
                 & Work(iwk),lwk,Ierror)
      END SUBROUTINE DSFVPES

      
      SUBROUTINE DSFVPES1(Nlat,Nlon,Isym,Nt,Sf,Vp,Idv,Jdv,Br,Bi,Cr,Ci,   &
                       & Mdb,Ndb,A,B,Mab,Fnn,Wshses,Lshses,Wk,Lwk,      &
                       & Ierror)
      IMPLICIT NONE

      INTEGER Nlat , Nlon , Isym , Nt , Idv , Jdv , Mdb , Ndb , Mab ,   &
            & Lshses , Lwk , Ierror
      DOUBLE PRECISION Sf(Idv,Jdv,Nt) , Vp(Idv,Jdv,Nt)
      DOUBLE PRECISION Br(Mdb,Ndb,Nt) , Bi(Mdb,Ndb,Nt) , Cr(Mdb,Ndb,Nt) ,           &
         & Ci(Mdb,Ndb,Nt)
      DOUBLE PRECISION A(Mab,Nlat,Nt) , B(Mab,Nlat,Nt)
      DOUBLE PRECISION Wshses(Lshses) , Wk(Lwk) , Fnn(Nlat)
      INTEGER n , m , mmax , k
!
!     set coefficient multiplyers
!
      DO n = 2 , Nlat
         Fnn(n) = 1.0/SQRT(FLOAT(n*(n-1)))
      ENDDO
      mmax = MIN0(Nlat,(Nlon+1)/2)
!
!     compute sf scalar coefficients from cr,ci
!
      DO k = 1 , Nt
         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) = -Fnn(n)*Cr(1,n,k)
            B(1,n,k) = -Fnn(n)*Ci(1,n,k)
         ENDDO
!
!     compute m>0 coefficients using vector spherepack value for mmax
!
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = -Fnn(n)*Cr(m,n,k)
               B(m,n,k) = -Fnn(n)*Ci(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize a,b into st
!
      CALL DSHSES(Nlat,Nlon,Isym,Nt,Sf,Idv,Jdv,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
!
!    set coefficients for vp from br,bi
!
      DO k = 1 , Nt
         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) = Fnn(n)*Br(1,n,k)
            B(1,n,k) = Fnn(n)*Bi(1,n,k)
         ENDDO
!
!     compute m>0 coefficients using vector spherepack value for mmax
!
         mmax = MIN0(Nlat,(Nlon+1)/2)
         DO m = 2 , mmax
            DO n = m , Nlat
               A(m,n,k) = Fnn(n)*Br(m,n,k)
               B(m,n,k) = Fnn(n)*Bi(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize a,b into vp
!
      CALL DSHSES(Nlat,Nlon,Isym,Nt,Vp,Idv,Jdv,A,B,Mab,Nlat,Wshses,      &
               & Lshses,Wk,Lwk,Ierror)
      END SUBROUTINE DSFVPES1
