!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
! ... file islapgs.f
!
!     this file includes documentation and code for
!     subroutine islapgs         i
!
! ... files which must be loaded with islapec.f
!
!     sphcom.f, hrfft.f, shags.f, shsgs.f
!
!     subroutine islapgs(nlat,nlon,isym,nt,xlmbda,sf,ids,jds,a,b,
!    +mdab,ndab,wshsgs,lshsgs,work,lwork,pertrb,ierror)
!
!     islapgs inverts the laplace or helmholz operator on a Gaussian grid.
!     Given the spherical harmonic coefficients a(m,n) and b(m,n) of the
!     right hand side slap(i,j), islapgc computes a solution sf(i,j) to
!     the following helmhotz equation :
!
!           2                2
!     [d(sf(i,j))/dlambda /sint + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint
!
!                   - xlmbda * sf(i,j) = slap(i,j)
!
!      where sf(i,j) is computed at the Gaussian colatitude point theta(i)
!      (see nlat as an input argument) and longitude
!
!                 lambda(j) = (j-1)*2*pi/nlon
!
!            for i=1,...,nlat and j=1,...,nlon.
!
!
!
!     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 computed
!            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
!            if nlat is odd the equator will be included as the grid point
!            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 longitude 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 zero. the axisymmetric case corresponds to nlon=1.
!            the efficiency of the computation is improved when nlon
!            is a product of small prime numbers.
!
!     isym   this parameter should have the same value input to subroutine
!            shags to compute the coefficients a and b for the scalar field
!            slap.  isym is set as follows:
!
!            = 0  no symmetries exist in slap about the equator. scalar
!                 synthesis is used to compute sf on the entire sphere.
!                 i.e., in the array sf(i,j) for i=1,...,nlat and
!                 j=1,...,nlon.
!
!           = 1  sf and slap are antisymmetric about the equator. the
!                synthesis used to compute sf is performed on the
!                northern hemisphere only.  if nlat is odd, sf(i,j) is
!                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
!                nlat is even, sf(i,j) is computed for i=1,...,nlat/2
!                and j=1,...,nlon.
!
!
!           = 2  sf and slap are symmetric about the equator. the
!                synthesis used to compute sf is performed on the
!                northern hemisphere only.  if nlat is odd, sf(i,j) is
!                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
!                nlat is even, sf(i,j) is computed for i=1,...,nlat/2
!                and j=1,...,nlon.
!
!
!     nt     the number of analyses.  in the program that calls islapgs
!            the arrays sf,a, and b can be three dimensional in which
!            case multiple synthesis will be performed.  the third index
!            is the synthesis index which assumes the values k=1,...,nt.
!            k is also the index for the perturbation array pertrb.
!            for a single analysis set nt=1. the description of the
!            remaining parameters is simplified by assuming that nt=1
!            or that sf,a,b are two dimensional and pertrb is a constant.
!
!   xlmbda   a one dimensional array with nt elements. if xlmbda is
!            is identically zero islapgc solves poisson's equation.
!            if xlmbda > 0.0 islapgc solves the helmholtz equation.
!            if xlmbda < 0.0 the nonfatal error flag ierror=-1 is
!            returned. negative xlambda could result in a division
!            by zero.
!
!   ids      the first dimension of the array sf as it appears in the
!            program that calls islapgs.  if isym = 0 then ids must be at
!            least nlat.  if isym > 0 and nlat is even then ids must be
!            at least nlat/2. if isym > 0 and nlat is odd then ids must
!            be at least (nlat+1)/2.
!
!   jds      the second dimension of the array sf as it appears in the
!            program that calls islapgs. jds 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 slap as computed by subroutine shags.
!     ***    a,b must be computed by shags prior to calling islapgs.
!
!
!    mdab    the first dimension of the arrays a and b as it appears
!            in the program that calls islapgs.  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 islapgs. ndbc must be at least
!            least nlat.
!
!            mdab,ndab should have the same values input to shags to
!            compute the coefficients a and b.
!
!
!    wshsgs  an array which must be initialized by subroutine islapgsi
!            (or equivalently by shsesi).  once initialized, wshsgs
!            can be used repeatedly by islapgs as long as nlat and nlon
!            remain unchanged.  wshsgs  must not be altered between calls
!            of islapgs.
!
!    lshsgs  the dimension of the array wshsgs as it appears in the
!            program that calls islapgs.  let
!
!               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 lshsgs must be at least
!
!            nlat*(3*(l1+l2)-2)+(l1-1)*(l2*(2*nlat-l1)-3*l1)/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 islapgs. 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 is zero then lwork must be at least
!
!               (nt+1)*nlat*nlon + nlat*(2*nt*l1+1)
!
!            if isym is nonzero lwork must be at least
!
!               (nt+1)*l2*nlon + nlat*(2*nt*l1+1)
!
!
!     **************************************************************
!
!     output parameters
!
!
!    sf      a two or three dimensional arrays (see input parameter nt) that
!            inverts the scalar laplacian in slap.  sf(i,j) is given at
!            the colatitude
!
!                 theta(i) = (i-1)*pi/(nlat-1)
!
!            and longitude
!
!                 lambda(j) = (j-1)*2*pi/nlon
!
!            for i=1,...,nlat and j=1,...,nlon.
!
!   pertrb  a one dimensional array with nt elements (see input
!           parameter nt). in the discription that follows we assume
!           that nt=1. if xlmbda > 0.0 then pertrb=0.0 is always
!           returned because the helmholtz operator is invertible.
!           if xlmbda = 0.0 then a solution exists only if a(1,1)
!           is zero. islapec sets a(1,1) to zero. the resulting
!           solution sf(i,j) solves poisson's equation with
!           pertrb = a(1,1)/(2.*sqrt(2.)) subtracted from the
!           right side slap(i,j).
!
!  ierror    a parameter which flags errors in input parameters as follows:
!
!            = 0  no errors detected
!
!            = 1  error in the specification of nlat
!
!            = 2  error in the specification of nlon
!
!            = 3  error in the specification of ityp
!
!            = 4  error in the specification of nt
!
!            = 5  error in the specification of ids
!
!            = 6  error in the specification of jds
!
!            = 7  error in the specification of mdbc
!
!            = 8  error in the specification of ndbc
!
!            = 9  error in the specification of lshsgs
!
!            = 10 error in the specification of lwork
!
!
! **********************************************************************
!
!     end of documentation for islapgs
!
! **********************************************************************
!
!
      SUBROUTINE ISLAPGS(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,  &
                       & Ndab,Wshsgs,Lshsgs,Work,Lwork,Pertrb,Ierror)
      IMPLICIT NONE

      REAL A , B , Pertrb , Sf , Work , Wshsgs , Xlmbda
      INTEGER ia , ib , Ids , Ierror , ifn , imid , Isym , iwk , Jds ,  &
            & k , l1 , l2 , lp , ls , Lshsgs , lwk , lwkmin , Lwork ,   &
            & Mdab , mmax
      INTEGER mn , Ndab , Nlat , nln , Nlon , Nt

      DIMENSION Sf(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wshsgs(Lshsgs) , Work(Lwork) , Xlmbda(Nt) , Pertrb(Nt)
!
!     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. Ids<Nlat) .OR. (Isym>0 .AND. Ids<imid) )      &
         & RETURN
      Ierror = 6
      IF ( Jds<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,Nlon/2+1)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
!
!     set and verify saved work space length
!
      imid = (Nlat+1)/2
      l2 = (Nlat+MOD(Nlat,2))/2
      l1 = MIN0((Nlon+2)/2,Nlat)
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshsgs<lp ) RETURN
      Ierror = 10
!
!     set and verify unsaved work space length
!
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
      mn = mmax*Nlat*Nt
!     lwkmin = nln+ls*nlon+2*mn+nlat
!     if (lwork .lt. lwkmin) return
      l2 = (Nlat+1)/2
      l1 = MIN0(Nlat,Nlon/2+1)
      IF ( Isym==0 ) THEN
         lwkmin = (Nt+1)*Nlat*Nlon + Nlat*(2*Nt*l1+1)
      ELSE
         lwkmin = (Nt+1)*l2*Nlon + Nlat*(2*Nt*l1+1)
      ENDIF
      IF ( Lwork<lwkmin ) RETURN
      Ierror = 0
!
!     check sign of xlmbda
!
      DO k = 1 , Nt
         IF ( Xlmbda(k)<0.0 ) Ierror = -1
      ENDDO
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      ifn = ib + mn
      iwk = ifn + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL ISLPGS1(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,Ndab,   &
                 & Work(ia),Work(ib),mmax,Work(ifn),Wshsgs,Lshsgs,      &
                 & Work(iwk),lwk,Pertrb,Ierror)
    END SUBROUTINE ISLAPGS

    
    SUBROUTINE ISLPGS1(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,  &
                       & Ndab,As,Bs,Mmax,Fnn,Wsav,Lsav,Wk,Lwk,Pertrb,   &
                       & Ierror)
      IMPLICIT NONE
      REAL A , As , B , Bs , fn , Fnn , Pertrb , Sf , Wk , Wsav , Xlmbda
      INTEGER Ids , Ierror , Isym , Jds , k , Lsav , Lwk , m , Mdab ,   &
            & Mmax , n , Ndab , Nlat , Nlon , Nt
      DIMENSION Sf(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION As(Mmax,Nlat,Nt) , Bs(Mmax,Nlat,Nt) , Fnn(Nlat)
      DIMENSION Wsav(Lsav) , Wk(Lwk) , Xlmbda(Nt) , Pertrb(Nt)
!
!     set multipliers and preset synthesis coefficients to zero
!
      DO n = 1 , Nlat
         fn = FLOAT(n-1)
         Fnn(n) = fn*(fn+1.0)
         DO m = 1 , Mmax
            DO k = 1 , Nt
               As(m,n,k) = 0.0
               Bs(m,n,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
 
      DO k = 1 , Nt
!
!     compute synthesis coefficients for xlmbda zero or nonzero
!
         IF ( Xlmbda(k)==0.0 ) THEN
            DO n = 2 , Nlat
               As(1,n,k) = -A(1,n,k)/Fnn(n)
               Bs(1,n,k) = -B(1,n,k)/Fnn(n)
            ENDDO
            DO m = 2 , Mmax
               DO n = m , Nlat
                  As(m,n,k) = -A(m,n,k)/Fnn(n)
                  Bs(m,n,k) = -B(m,n,k)/Fnn(n)
               ENDDO
            ENDDO
         ELSE
!
!     xlmbda nonzero so operator invertible unless
!     -n*(n-1) = xlmbda(k) < 0.0  for some n
!
            Pertrb(k) = 0.0
            DO n = 1 , Nlat
               As(1,n,k) = -A(1,n,k)/(Fnn(n)+Xlmbda(k))
               Bs(1,n,k) = -B(1,n,k)/(Fnn(n)+Xlmbda(k))
            ENDDO
            DO m = 2 , Mmax
               DO n = m , Nlat
                  As(m,n,k) = -A(m,n,k)/(Fnn(n)+Xlmbda(k))
                  Bs(m,n,k) = -B(m,n,k)/(Fnn(n)+Xlmbda(k))
               ENDDO
            ENDDO
         ENDIF
      ENDDO
!
!     synthesize as,bs into sf
!
      CALL SHSGS(Nlat,Nlon,Isym,Nt,Sf,Ids,Jds,As,Bs,Mmax,Nlat,Wsav,Lsav,&
               & Wk,Lwk,Ierror)
    END SUBROUTINE ISLPGS1


    SUBROUTINE DISLAPGS(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,  &
                       & Ndab,Wshsgs,Lshsgs,Work,Lwork,Pertrb,Ierror)
      IMPLICIT NONE

      DOUBLE PRECISION A , B , Pertrb , Sf , Work , Wshsgs , Xlmbda
      INTEGER ia , ib , Ids , Ierror , ifn , imid , Isym , iwk , Jds ,  &
            & k , l1 , l2 , lp , ls , Lshsgs , lwk , lwkmin , Lwork ,   &
            & Mdab , mmax
      INTEGER mn , Ndab , Nlat , nln , Nlon , Nt

      DIMENSION Sf(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wshsgs(Lshsgs) , Work(Lwork) , Xlmbda(Nt) , Pertrb(Nt)
!
!     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. Ids<Nlat) .OR. (Isym>0 .AND. Ids<imid) )      &
         & RETURN
      Ierror = 6
      IF ( Jds<Nlon ) RETURN
      Ierror = 7
      mmax = MIN0(Nlat,Nlon/2+1)
      IF ( Mdab<mmax ) RETURN
      Ierror = 8
      IF ( Ndab<Nlat ) RETURN
      Ierror = 9
!
!     set and verify saved work space length
!
      imid = (Nlat+1)/2
      l2 = (Nlat+MOD(Nlat,2))/2
      l1 = MIN0((Nlon+2)/2,Nlat)
      lp = Nlat*(3*(l1+l2)-2) + (l1-1)*(l2*(2*Nlat-l1)-3*l1)/2 + Nlon + &
         & 15
      IF ( Lshsgs<lp ) RETURN
      Ierror = 10
!
!     set and verify unsaved work space length
!
      ls = Nlat
      IF ( Isym>0 ) ls = imid
      nln = Nt*ls*Nlon
      mn = mmax*Nlat*Nt
!     lwkmin = nln+ls*nlon+2*mn+nlat
!     if (lwork .lt. lwkmin) return
      l2 = (Nlat+1)/2
      l1 = MIN0(Nlat,Nlon/2+1)
      IF ( Isym==0 ) THEN
         lwkmin = (Nt+1)*Nlat*Nlon + Nlat*(2*Nt*l1+1)
      ELSE
         lwkmin = (Nt+1)*l2*Nlon + Nlat*(2*Nt*l1+1)
      ENDIF
      IF ( Lwork<lwkmin ) RETURN
      Ierror = 0
!
!     check sign of xlmbda
!
      DO k = 1 , Nt
         IF ( Xlmbda(k)<0.0 ) Ierror = -1
      ENDDO
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      ifn = ib + mn
      iwk = ifn + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL DISLPGS1(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,Ndab,   &
                 & Work(ia),Work(ib),mmax,Work(ifn),Wshsgs,Lshsgs,      &
                 & Work(iwk),lwk,Pertrb,Ierror)
    END SUBROUTINE DISLAPGS

    
    SUBROUTINE DISLPGS1(Nlat,Nlon,Isym,Nt,Xlmbda,Sf,Ids,Jds,A,B,Mdab,  &
                       & Ndab,As,Bs,Mmax,Fnn,Wsav,Lsav,Wk,Lwk,Pertrb,   &
                       & Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , As , B , Bs , fn , Fnn , Pertrb , Sf , Wk , Wsav , Xlmbda
      INTEGER Ids , Ierror , Isym , Jds , k , Lsav , Lwk , m , Mdab ,   &
            & Mmax , n , Ndab , Nlat , Nlon , Nt
      DIMENSION Sf(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION As(Mmax,Nlat,Nt) , Bs(Mmax,Nlat,Nt) , Fnn(Nlat)
      DIMENSION Wsav(Lsav) , Wk(Lwk) , Xlmbda(Nt) , Pertrb(Nt)
!
!     set multipliers and preset synthesis coefficients to zero
!
      DO n = 1 , Nlat
         fn = FLOAT(n-1)
         Fnn(n) = fn*(fn+1.0)
         DO m = 1 , Mmax
            DO k = 1 , Nt
               As(m,n,k) = 0.0
               Bs(m,n,k) = 0.0
            ENDDO
         ENDDO
      ENDDO
 
      DO k = 1 , Nt
!
!     compute synthesis coefficients for xlmbda zero or nonzero
!
         IF ( Xlmbda(k)==0.0 ) THEN
            DO n = 2 , Nlat
               As(1,n,k) = -A(1,n,k)/Fnn(n)
               Bs(1,n,k) = -B(1,n,k)/Fnn(n)
            ENDDO
            DO m = 2 , Mmax
               DO n = m , Nlat
                  As(m,n,k) = -A(m,n,k)/Fnn(n)
                  Bs(m,n,k) = -B(m,n,k)/Fnn(n)
               ENDDO
            ENDDO
         ELSE
!
!     xlmbda nonzero so operator invertible unless
!     -n*(n-1) = xlmbda(k) < 0.0  for some n
!
            Pertrb(k) = 0.0
            DO n = 1 , Nlat
               As(1,n,k) = -A(1,n,k)/(Fnn(n)+Xlmbda(k))
               Bs(1,n,k) = -B(1,n,k)/(Fnn(n)+Xlmbda(k))
            ENDDO
            DO m = 2 , Mmax
               DO n = m , Nlat
                  As(m,n,k) = -A(m,n,k)/(Fnn(n)+Xlmbda(k))
                  Bs(m,n,k) = -B(m,n,k)/(Fnn(n)+Xlmbda(k))
               ENDDO
            ENDDO
         ENDIF
      ENDDO
!
!     synthesize as,bs into sf
!
      CALL DSHSGS(Nlat,Nlon,Isym,Nt,Sf,Ids,Jds,As,Bs,Mmax,Nlat,Wsav,Lsav,&
               & Wk,Lwk,Ierror)
    END SUBROUTINE DISLPGS1
