!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                         SPHEREPACK3.0                       .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!
!
!
! ... file slapec.f
!
!     this file includes documentation and code for
!     subroutine slapec          i
!
! ... files which must be loaded with slapec.f
!
!     sphcom.f, hrfft.f, shaec.f, shsec.f
!
!
!
!     subroutine slapec(nlat,nlon,isym,nt,slap,ids,jds,a,b,mdab,ndab,
!    +                  wshsec,lshsec,work,lwork,ierror)
!
!
!     given the scalar spherical harmonic coefficients a and b, precomputed
!     by subroutine shaec for a scalar field sf, subroutine slapec computes
!     the laplacian of sf in the scalar array slap.  slap(i,j) is the
!     laplacian of sf at the colatitude
!
!         theta(i) = (i-1)*pi/(nlat-1)
!
!     and east longitude
!
!         lambda(j) = (j-1)*2*pi/nlon
!
!     on the sphere.  i.e.
!
!         slap(i,j) =
!
!                  2                2
!         [1/sint*d (sf(i,j)/dlambda + d(sint*d(sf(i,j))/dtheta)/dtheta]/sint
!
!
!     where sint = sin(theta(i)).  the scalar laplacian in slap has the
!     same symmetry or absence of symmetry about the equator as the scalar
!     field sf.  the input parameters isym,nt,mdab,ndab must have the
!     same values used by shaec to compute a and b for sf. the associated
!     legendre functions are recomputed rather than stored as they are
!     in subroutine slapes.
 
!
!     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 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
!            shaec to compute the coefficients a and b for the scalar field
!            sf.  isym is set as follows:
!
!            = 0  no symmetries exist in sf about the equator. scalar
!                 synthesis is used to compute slap on the entire sphere.
!                 i.e., in the array slap(i,j) for i=1,...,nlat and
!                 j=1,...,nlon.
!
!           = 1  sf and slap are antisymmetric about the equator. the
!                synthesis used to compute slap is performed on the
!                northern hemisphere only.  if nlat is odd, slap(i,j) is
!                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
!                nlat is even, slap(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 slap is performed on the
!                northern hemisphere only.  if nlat is odd, slap(i,j) is
!                computed for i=1,...,(nlat+1)/2 and j=1,...,nlon.  if
!                nlat is even, slap(i,j) is computed for i=1,...,nlat/2
!                and j=1,...,nlon.
!
!
!     nt     the number of analyses.  in the program that calls slapec
!            the arrays slap,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.
!            for a single analysis set nt=1. the description of the
!            remaining parameters is simplified by assuming that nt=1
!            or that all the arrays are two dimensional.
!
!   ids      the first dimension of the array slap as it appears in the
!            program that calls slapec.  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 slap as it appears in the
!            program that calls slapec. 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 sf as computed by subroutine shaec.
!     ***    a,b must be computed by shaec prior to calling slapec.
!
!
!    mdab    the first dimension of the arrays a and b as it appears
!            in the program that calls slapec.  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 slapec. ndbc must be at least
!            least nlat.
!
!            mdab,ndab should have the same values input to shaec to
!            compute the coefficients a and b.
!
!
!    wshsec  an array which must be initialized by subroutine shseci
!            before calling slapec.  once initialized, wshsec
!            can be used repeatedly by slapec as long as nlat and nlon
!            remain unchanged.  wshsec must not be altered between calls
!            of slapec.
!
!    lshsec  the dimension of the array wshsec as it appears in the
!            program that calls slapec.  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 lshsec must be greater than or equal to
!
!               2*nlat*l2+3*((l1-2)*(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 slapec. 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 let
!
!               lwkmin = nlat*(2*nt*nlon+max0(6*l2,nlon)+2*nt*l1+1.
!
!            if isym > 0 let
!
!               lwkmin = l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(2*nt*l1+1)
!
!
!     then lwork must be greater than or equal to lwkmin (see ierror=10)
!
!     **************************************************************
!
!     output parameters
!
!
!    slap    a two or three dimensional arrays (see input parameter nt) that
!            contain the scalar laplacian of the scalar field sf.  slap(i,j)
!            is the scalar laplacian 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.
!
!
!  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 lshsec
!
!            = 10 error in the specification of lwork
!
!
! **********************************************************************
!
!     end of documentation for slapec
!
! **********************************************************************
!
!
      SUBROUTINE SLAPEC(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,   &
                      & Wshsec,Lshsec,Work,Lwork,Ierror)
      IMPLICIT NONE
      REAL A , B , Slap , Work , Wshsec
      INTEGER ia , ib , Ids , Ierror , ifn , imid , Isym , iwk , Jds ,  &
            & l1 , l2 , ls , Lshsec , lwk , lwkmin , lwmin , Lwork ,    &
            & Mdab , mmax , mn
      INTEGER Ndab , Nlat , nln , Nlon , Nt
      DIMENSION Slap(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wshsec(Lshsec) , 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. 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
!
!
      l1 = MIN0(Nlat,(Nlon+2)/2)
      l2 = (Nlat+1)/2
      lwmin = 2*Nlat*l2 + 3*((l1-2)*(Nlat+Nlat-l1-1))/2 + Nlon + 15
      IF ( Lshsec<lwmin ) 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
!     lwmin = nln+ls*nlon+2*mn+nlat
!     if (lwork .lt. lwmin) return
      l2 = (Nlat+1)/2
      l1 = MIN0(Nlat,Nlon/2+1)
      IF ( Isym==0 ) THEN
         lwkmin = Nlat*(2*Nt*Nlon+MAX0(6*l2,Nlon)+2*Nt*l1+1)
      ELSE
         lwkmin = l2*(2*Nt*Nlon+MAX0(6*Nlat,Nlon)) + Nlat*(2*Nt*l1+1)
      ENDIF
      IF ( Lwork<lwkmin ) RETURN
 
 
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      ifn = ib + mn
      iwk = ifn + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL SLAPEC1(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,Work(ia)&
                 & ,Work(ib),mmax,Work(ifn),Wshsec,Lshsec,Work(iwk),lwk,&
                 & Ierror)
      END SUBROUTINE SLAPEC


      
      SUBROUTINE SLAPEC1(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,  &
                       & Alap,Blap,Mmax,Fnn,Wshsec,Lshsec,Wk,Lwk,Ierror)
      IMPLICIT NONE
      REAL A , Alap , B , Blap , fn , Fnn , Slap , Wk , Wshsec
      INTEGER Ids , Ierror , Isym , Jds , k , Lshsec , Lwk , m , Mdab , &
            & Mmax , n , Ndab , Nlat , Nlon , Nt
      DIMENSION Slap(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Alap(Mmax,Nlat,Nt) , Blap(Mmax,Nlat,Nt) , Fnn(Nlat)
      DIMENSION Wshsec(Lshsec) , Wk(Lwk)
!
!     set coefficient multiplyers
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Fnn(n) = fn*(fn+1.)
      ENDDO
!
!     compute scalar laplacian coefficients for each vector field
!
      DO k = 1 , Nt
         DO n = 1 , Nlat
            DO m = 1 , Mmax
               Alap(m,n,k) = 0.0
               Blap(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            Alap(1,n,k) = -Fnn(n)*A(1,n,k)
            Blap(1,n,k) = -Fnn(n)*B(1,n,k)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , Mmax
            DO n = m , Nlat
               Alap(m,n,k) = -Fnn(n)*A(m,n,k)
               Blap(m,n,k) = -Fnn(n)*B(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize alap,blap into slap
!
      CALL SHSEC(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,Alap,Blap,Mmax,Nlat,    &
               & Wshsec,Lshsec,Wk,Lwk,Ierror)
      END SUBROUTINE SLAPEC1


      SUBROUTINE DSLAPEC(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,   &
                      & Wshsec,Lshsec,Work,Lwork,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , B , Slap , Work , Wshsec
      INTEGER ia , ib , Ids , Ierror , ifn , imid , Isym , iwk , Jds ,  &
            & l1 , l2 , ls , Lshsec , lwk , lwkmin , lwmin , Lwork ,    &
            & Mdab , mmax , mn
      INTEGER Ndab , Nlat , nln , Nlon , Nt
      DIMENSION Slap(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Wshsec(Lshsec) , 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. 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
!
!
      l1 = MIN0(Nlat,(Nlon+2)/2)
      l2 = (Nlat+1)/2
      lwmin = 2*Nlat*l2 + 3*((l1-2)*(Nlat+Nlat-l1-1))/2 + Nlon + 15
      IF ( Lshsec<lwmin ) 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
!     lwmin = nln+ls*nlon+2*mn+nlat
!     if (lwork .lt. lwmin) return
      l2 = (Nlat+1)/2
      l1 = MIN0(Nlat,Nlon/2+1)
      IF ( Isym==0 ) THEN
         lwkmin = Nlat*(2*Nt*Nlon+MAX0(6*l2,Nlon)+2*Nt*l1+1)
      ELSE
         lwkmin = l2*(2*Nt*Nlon+MAX0(6*Nlat,Nlon)) + Nlat*(2*Nt*l1+1)
      ENDIF
      IF ( Lwork<lwkmin ) RETURN
 
 
      Ierror = 0
!
!     set work space pointers
!
      ia = 1
      ib = ia + mn
      ifn = ib + mn
      iwk = ifn + Nlat
      lwk = Lwork - 2*mn - Nlat
      CALL DSLAPEC1(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,Work(ia)&
                 & ,Work(ib),mmax,Work(ifn),Wshsec,Lshsec,Work(iwk),lwk,&
                 & Ierror)
      END SUBROUTINE DSLAPEC


      
      SUBROUTINE DSLAPEC1(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,A,B,Mdab,Ndab,  &
                       & Alap,Blap,Mmax,Fnn,Wshsec,Lshsec,Wk,Lwk,Ierror)
      IMPLICIT NONE
      DOUBLE PRECISION A , Alap , B , Blap , fn , Fnn , Slap , Wk , Wshsec
      INTEGER Ids , Ierror , Isym , Jds , k , Lshsec , Lwk , m , Mdab , &
            & Mmax , n , Ndab , Nlat , Nlon , Nt
      DIMENSION Slap(Ids,Jds,Nt) , A(Mdab,Ndab,Nt) , B(Mdab,Ndab,Nt)
      DIMENSION Alap(Mmax,Nlat,Nt) , Blap(Mmax,Nlat,Nt) , Fnn(Nlat)
      DIMENSION Wshsec(Lshsec) , Wk(Lwk)
!
!     set coefficient multiplyers
!
      DO n = 2 , Nlat
         fn = FLOAT(n-1)
         Fnn(n) = fn*(fn+1.)
      ENDDO
!
!     compute scalar laplacian coefficients for each vector field
!
      DO k = 1 , Nt
         DO n = 1 , Nlat
            DO m = 1 , Mmax
               Alap(m,n,k) = 0.0
               Blap(m,n,k) = 0.0
            ENDDO
         ENDDO
!
!     compute m=0 coefficients
!
         DO n = 2 , Nlat
            Alap(1,n,k) = -Fnn(n)*A(1,n,k)
            Blap(1,n,k) = -Fnn(n)*B(1,n,k)
         ENDDO
!
!     compute m>0 coefficients
!
         DO m = 2 , Mmax
            DO n = m , Nlat
               Alap(m,n,k) = -Fnn(n)*A(m,n,k)
               Blap(m,n,k) = -Fnn(n)*B(m,n,k)
            ENDDO
         ENDDO
      ENDDO
!
!     synthesize alap,blap into slap
!
      CALL DSHSEC(Nlat,Nlon,Isym,Nt,Slap,Ids,Jds,Alap,Blap,Mmax,Nlat,    &
               & Wshsec,Lshsec,Wk,Lwk,Ierror)
      END SUBROUTINE DSLAPEC1
