SUBROUTINE lfnorm(n, m, x, y, beta, z, ky, ifault)

!     ALGORITHM AS 135  APPL. STATIST. (1979) VOL.28, NO. 1

!     Min-Max estimates for a linear multiple regression problem

! Input arguments
! ---------------
! N      Number of cases
! M      Number of predictors
! X(,)   Values of the predictor variables, one case per row.
! Y()    Values of the dependent variable

! Output arguments
! ----------------
! BETA() Final estimates of the regression coefficients
! Z      The least maximum absolute deviation
! KY     The number of iterations
! IFAULT Error indicator = 0 for normal termination
!                        = 1 if the observation matrix has less than full rank
!
! N.B. Arguments NDIM & MDIM have been removed.

! Fortran 90 version by Alan.Miller @ vic.cmis.csiro.au
! Latest revision - 5 January 1999

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)     :: n
INTEGER, INTENT(IN)     :: m
REAL (dp), INTENT(IN)   :: x(:, :)   ! x(ndim, mdim)
REAL (dp), INTENT(IN)   :: y(:)
REAL (dp), INTENT(OUT)  :: beta(:)
REAL (dp), INTENT(OUT)  :: z
INTEGER, INTENT(OUT)    :: ky
INTEGER, INTENT(OUT)    :: ifault

REAL (dp) :: hilo(m), xrxf(m), xsxf(m), lu(m, m), dev1, sigr, sumxr,  &
             deviat, yest, ydev, sumxs, ratio, test, delta, div, swing,    &
             SAVE, sigs, top, acu, big
INTEGER   :: i, ibase(m), ii, ii1, irow, k, kk, kkk, k1, k2, m1, sss, rrr,  &
             indx(m)
LOGICAL   :: intl

REAL (dp), PARAMETER :: zero = 0._dp, one = 1._dp, two = 2._dp

acu = SQRT( EPSILON(1.0_dp) )
big = SQRT( HUGE(1.0_dp) )
ifault = 0
ky = 0
z = zero
m1 = m - 1

!     Set up initial LU decomposition

DO i = 1, m
  indx(i) = i
END DO
intl = .true.
kkk = 1
CALL update(kkk, x, lu, ibase, indx, intl, n, m, ifault)
IF (ifault /= 0) RETURN
intl = .false.
irow = kkk

!     Calculate beta value

k = indx(1)
k1 = ibase(1)
beta(k) = y(k1) / lu(k, 1)
DO ii = 2, m
  k = indx(ii)
  k1 = ibase(ii)
  beta(k) = y(k1)
  ii1 = ii - 1
  DO i = 1, ii1
    kk = indx(i)
    beta(k) = beta(k) - lu(kk, ii) * beta(kk)
  END DO
  beta(k) = beta(k) / lu(k, ii)
END DO
DO ii = 1, m1
  k1 = m - ii
  k = indx(k1)
  DO i = 1, ii
    kk = m - i + 1
    k2 = indx(kk)
    beta(k) = beta(k) - lu(k2, k1) * beta(k2)
  END DO
END DO

!     Search for and set first violated constraint as R-th constraint

50 irow = irow + 1
IF (irow > n) RETURN
dev1 = zero
DO i = 1, m
  dev1 = dev1 + x(irow, i) * beta(i)
END DO
dev1 = dev1 - y(irow)
IF (ABS(dev1) < acu) GO TO 50
sigr = SIGN(one, dev1)
rrr = irow

!     Adjust for the R-th constraint

k = indx(1)
xrxf(1) = x(rrr, k)
DO ii = 2, m
  k = indx(ii)
  xrxf(ii) = x(rrr, k)
  ii1 = ii - 1
  DO i = 1, ii1
    xrxf(ii) = xrxf(ii) - lu(k, i) * xrxf(i)
  END DO
END DO
k = indx(m)
xrxf(m) = xrxf(m) / lu(k, m)
hilo(m) = SIGN(one, -sigr * xrxf(m))
sumxr = sigr - hilo(m) * xrxf(m)
DO ii = 1, m1
  k1 = m - ii
  k = indx(k1)
  DO i = 1, ii
    k2 = m - i + 1
    xrxf(k1) = xrxf(k1) - lu(k, k2) * xrxf(k2)
  END DO
  xrxf(k1) = xrxf(k1) / lu(k, k1)
  hilo(k1) = SIGN(one, -sigr * xrxf(k1))
  sumxr = sumxr - hilo(k1) * xrxf(k1)
END DO
z = ABS(dev1 / sumxr)

!     Start of main iterative loop.
!     Search for the most violated S-th constraint

110 sss = 0
deviat = acu

!     Calculate beta value

k = indx(1)
k1 = ibase(1)
beta(k) = (y(k1) + z * hilo(1)) / lu(k, 1)
DO ii = 2, m
  k = indx(ii)
  k1 = ibase(ii)
  beta(k) = y(k1) + z * hilo(ii)
  ii1 = ii - 1
  DO i = 1, ii1
    kk = indx(i)
    beta(k) = beta(k) - lu(kk, ii) * beta(kk)
  END DO
  beta(k) = beta(k) / lu(k, ii)
END DO
DO ii = 1, m1
  k1 = m - ii
  k = indx(k1)
  DO i = 1, ii
    kk = m - i + 1
    k2 = indx(kk)
    beta(k) = beta(k) - lu(k2, k1) * beta(k2)
  END DO
END DO

!     Calculate residuals

DO i = 1, n
  yest = DOT_PRODUCT( x(i, 1:m), beta(1:m) )
  dev1 = ABS(y(i) - yest) - z
  IF (dev1 <= deviat) CYCLE
  ydev = yest - y(i)
  deviat = dev1
  sss = i
END DO

!     Check if at optimum

IF (sss == 0) RETURN

!     Set up information on the S-th constraint

sigs = SIGN(one, ydev)
k = indx(1)
xsxf(1) = x(sss, k)
DO ii = 2, m
  k = indx(ii)
  xsxf(ii) = x(sss, k)
  ii1 = ii - 1
  DO i = 1, ii1
    xsxf(ii) = xsxf(ii) - lu(k, i) * xsxf(i)
  END DO
END DO
k = indx(m)
xsxf(m) = xsxf(m) / lu(k, m)
sumxs = -sigs + hilo(m) * xsxf(m)
DO ii = 1, m1
  k1 = m - ii
  k = indx(k1)
  DO i = 1, ii
    k2 = m - i + 1
    xsxf(k1) = xsxf(k1) - lu(k, k2) * xsxf(k2)
  END DO
  xsxf(k1) = xsxf(k1) / lu(k, k1)
  sumxs = sumxs + hilo(k1) * xsxf(k1)
END DO

!     Search for minimum ratio

210 kkk = 0
ratio = big
DO i = 1, m
  IF (sigs * SIGN(one, xsxf(i)) /= hilo(i) .OR. ABS(xsxf(i)) < acu) CYCLE
  test = ABS(xrxf(i) / xsxf(i))
  IF (test >= ratio) CYCLE
  ratio = test
  kkk = i
END DO

!     Check if R-th constraint moves interior

IF (kkk /= 0) GO TO 260

!     Process the movement of the R-th constraint

delta = ABS(deviat / sumxs)

!     Calculate the largest tolerable delta

div = ABS(sumxr) - two
IF (div < acu) GO TO 240
swing = two * z / div
IF (swing >= delta) GO TO 240

!     Switch R and S constraint indicators

SAVE = sumxs
sumxs = -sumxr + sigr + sigr
sumxr = -SAVE
SAVE = sigr
sigr = sigs
sigs = -SAVE
deviat = ABS(sumxs * delta) - two * z
z = z + delta
DO i = 1, m
  SAVE = xsxf(i)
  xsxf(i) = xrxf(i)
  xrxf(i) = SAVE
END DO
i = rrr
rrr = sss
sss = i
GO TO 210

!     Replace the R-th constraint with the S-th constraint

240 sigr = sigs
xrxf(1:m) = xsxf(1:m)
sumxr = -sumxs
z = z + delta
rrr = sss
GO TO 110

!     Process the movement of the K-th constraint

260 delta = ABS(xrxf(kkk) * deviat / (xrxf(kkk) * sumxs + xsxf(kkk) * sumxr))
top = -two * z * xrxf(kkk)
div = xrxf(kkk) * xrxf(kkk) + hilo(kkk) * sumxr
IF (SIGN(one, top) /= SIGN(one, div)) GO TO 270
IF (ABS(div) < acu) GO TO 270
swing = top / div

!     Check to see if the K-th constraint swings across

IF (swing >= delta) GO TO 270
z = z + swing
deviat = deviat - swing * ABS(sumxs + xsxf(kkk) * sumxr / xrxf(kkk))
sumxr = sumxr + two * hilo(kkk) * xrxf(kkk)
sumxs = sumxs - two * hilo(kkk) * xsxf(kkk)
hilo(kkk) = -hilo(kkk)
GO TO 210

!     Update XRXF and the LU of the current basis

270 hilo(kkk) = sigs
sumxr = sigr
xrxf(kkk) = xrxf(kkk) / xsxf(kkk)
sumxr = sumxr - hilo(kkk) * xrxf(kkk)
DO i = 1, m
  IF (i == kkk) CYCLE
  xrxf(i) = xrxf(i) - xsxf(i) * xrxf(kkk)
  sumxr = sumxr - hilo(i) * xrxf(i)
END DO
ibase(kkk) = sss

!     Update LU decomposition

CALL update(kkk, x, lu, ibase, indx, intl, n, m, ifault)
IF (ifault /= 0) RETURN
z = z + delta
ky = ky + 1
GO TO 110

CONTAINS

SUBROUTINE update(kkk, x, lu, ibase, indx, intl, n, m, ifault)

!     ALGORITHM AS 135.1  APPL. STATIST. (1979) VOL.28, NO. 1

!     Update LU decomposition matrix

INTEGER, INTENT(IN OUT)   :: kkk
REAL (dp), INTENT(IN)     :: x(:, :)   ! x(ndim, mdim)
REAL (dp), INTENT(IN OUT) :: lu(:, :)
INTEGER, INTENT(IN OUT)   :: ibase(:)
INTEGER, INTENT(IN OUT)   :: indx(:)
LOGICAL, INTENT(IN OUT)   :: intl
INTEGER, INTENT(IN)       :: n
INTEGER, INTENT(IN)       :: m
INTEGER, INTENT(OUT)      :: ifault

! Local variables

REAL (dp) :: subt, pivot
INTEGER   :: i, icol, ii, ii1, irow, isave, j, k, kk

irow = 0
DO ii = kkk, m
  IF (intl) GO TO 10
  irow = ibase(ii)
  GO TO 20

  10 irow = irow + 1
  IF (irow > n) THEN
    ifault = 1
    RETURN
  END IF
  20 lu(1:m, ii) = x(irow, 1:m)

!     Set up representation of incoming row

  IF (ii == 1) GO TO 60
  ii1 = ii - 1
  DO icol = 1, ii1
    k = indx(icol)
    subt = lu(k, ii)
    j = icol + 1
    DO i = j, m
      k = indx(i)
      lu(k, ii) = lu(k, ii) - subt * lu(k, icol)
    END DO
  END DO

!     Find maximum entry

  60 pivot = acu
  kk = 0
  DO i = ii, m
    k = indx(i)
    IF (ABS(lu(k, ii)) <= pivot) CYCLE
    pivot = ABS(lu(k, ii))
    kk = i
  END DO
  IF (kk == 0) GO TO 10

!     Switch order

  isave = indx(kk)
  indx(kk) = indx(ii)
  indx(ii) = isave

!     Put into columns of LU one at a time

  IF (intl) ibase(ii) = irow
  IF (ii == m) CYCLE
  j = ii + 1
  DO i = j, m
    k = indx(i)
    lu(k, ii) = lu(k, ii) / lu(isave, ii)
  END DO
END DO
kkk = irow

RETURN
END SUBROUTINE update

END SUBROUTINE lfnorm

PROGRAM test_lfnorm
IMPLICIT NONE

INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
INTEGER                :: i, ier, niter, m, n
REAL (dp), ALLOCATABLE :: x(:,:), y(:), beta(:)
REAL (dp)              :: z

INTERFACE
  SUBROUTINE lfnorm(n, m, x, y, beta, z, ky, ifault)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    INTEGER, INTENT(IN)     :: n
    INTEGER, INTENT(IN)     :: m
    REAL (dp), INTENT(IN)   :: x(:, :)   ! x(ndim, mdim)
    REAL (dp), INTENT(IN)   :: y(:)
    REAL (dp), INTENT(OUT)  :: beta(:)
    REAL (dp), INTENT(OUT)  :: z
    INTEGER, INTENT(OUT)    :: ky
    INTEGER, INTENT(OUT)    :: ifault
  END SUBROUTINE lfnorm
END INTERFACE

DO
  WRITE(*, '(a)', ADVANCE='NO') ' Enter number of predictor variables: '
  READ(*, *) m
  IF (m < 1) THEN
    WRITE(*, *) '** Must be greater than zero **'
    CYCLE
  ELSE
    EXIT
  END IF
END DO

n = 3 * m

ALLOCATE( x(n,m), y(n), beta(m) )

! Generate artificial data with coefficients 1, 2, ..., m.

beta = (/ (DBLE(i),i=1,m) /)
DO i = 1, n
  CALL RANDOM_NUMBER( x(i,2:) )
  CALL RANDOM_NUMBER( z )
  x(i,1) = 1.0_dp
  y(i) = DOT_PRODUCT( x(i,:), beta ) + z - 0.5_dp
END DO

CALL lfnorm(n, m, x, y, beta, z, niter, ier)
IF (ier > 0) THEN
  WRITE(*, *) '** X-matrix has rank < m **'
ELSE
  WRITE(*, *) 'Regression coefficients'
  WRITE(*, '(t2, 10f7.3)') beta
  WRITE(*, '(a, i6)') ' No. of iterations = ', niter
  WRITE(*, '(a, f9.5)') ' Least max. abs. deviation = ', z
END IF

STOP
END PROGRAM test_lfnorm


      FUNCTION FACTRL(N)
      DIMENSION A(33)
      DATA NTOP,A(1)/0,1./
      IF (N.LT.0) THEN
        PAUSE 'negative factorial'
      ELSE IF (N.LE.NTOP) THEN
        FACTRL=A(N+1)
      ELSE IF (N.LE.32) THEN
        DO 11 J=NTOP+1,N
          A(J+1)=J*A(J)
11      CONTINUE
        NTOP=N
        FACTRL=A(N+1)
      ELSE
        FACTRL=EXP(GAMMLN(N+1.))
      ENDIF
      RETURN
      END


! =====================================================================
! function KPXV
!
! This function computes the expectation value of the angular momentum
! operator.
! ---------------------------------------------------------------------
      double precision function KPXV(nRP,nR,nP,dP,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: dP
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k
      double complex :: a

      KPXV = 0.0d0
      a = dcmplx(0.0d0,-0.5d0/dP)

      k = 0
      do j = 1, nR
         k = k + 1
         KPXV = KPXV + dble(dconjg(U(k))*a*(U(k+1)-U(k+nP-1)))*RdRP(j)
         do i = 2, nP-1
            k = k + 1
            KPXV = KPXV + dble(dconjg(U(k))*a*(U(k+1)-U(k-1)))*RdRP(j)
         enddo
         k = k + 1
         KPXV = KPXV + dble(dconjg(U(k))*a*(U(k-nP+1)-U(k-1)))*RdRP(j)
      enddo

      return
      end
! =====================================================================


c
c      this file contains the basic subroutines for
c      forming and evaluating multipole expansions.
c
c      remarks on scaling conventions.
c
c      1)  far field and local expansions are consistently rscaled as
c
c
c          m_n^m (scaled) = m_n^m / rscale^(n)  so that upon evaluation
c
c          the field is  sum   m_n^m (scaled) * rscale^(n) / r^{n+1}.
c
c          l_n^m (scaled) = l_n^m * rscale^(n)  so that upon evaluation
c
c          the field is  sum   l_n^m (scaled) / rscale^(n) * r^{n}.
c
c
c      2) there are many definitions of the spherical harmonics,
c         which differ in terms of normalization constants. we
c         adopt the following convention:
c
c         for m>0, we define y_n^m according to
c
c         y_n^m = \sqrt{2n+1} \sqrt{\frac{ (n-m)!}{(n+m)!}} \cdot
c                 p_n^m(\cos \theta)  e^{i m phi}
c         and
c
c         y_n^-m = dconjg( y_n^m )
c
c         we omit the condon-shortley phase factor (-1)^m in the
c         definition of y_n^m for m<0. (this is standard in several
c         communities.)
c
c         we also omit the factor \sqrt{\frac{1}{4 \pi}}, so that
c         the y_n^m are orthogonal on the unit sphere but not
c         orthonormal.  (this is also standard in several communities.)
c         more precisely,
c
c                 \int_s y_n^m y_n^m d\omega = 4 \pi.
c
c         using our standard definition, the addition theorem takes
c         the simple form
c
c         1/r =
c         \sum_n 1/(2n+1) \sum_m  |s|^n ylm*(s) ylm(t)/ (|t|^(n+1))
c
c         1/r =
c         \sum_n \sum_m  |s|^n  ylm*(s)    ylm(t)     / (|t|^(n+1))
c                               -------    ------
c                               sqrt(2n+1) sqrt(2n+1)
c
c        in the laplace library (this library), we incorporate the
c        sqrt(2n+1) factor in both forming and evaluating multipole
c        expansions.
c
c-----------------------------------------------------------------------
c
c      l3dmpevalp: computes potential due to a multipole expansion
c                    at a collection of targets (done,tested)
c
c      l3dmpevalg: computes potential and gradients
c                  due to a multipole expansion
c                    at a collection of targets (done,tested)
c
c      l3dformmpc: creates multipole expansion (outgoing) due to
c                 a collection of charges (done,tested)
c
c      l3dformmpd: creates multipole expansion (outgoing) due to
c                 a collection of dipoles (done,tested)
c
c      l3dformmpcd: creates multipole expansion (outgoing) due to
c                 a collection of charges and dipoles (done,tested)
c
c      l3dtaevalp: computes potential
c                  due to local expansion at a collection of targets
c
c      l3dtaevalp: computes potential and gradients
c                  due to local expansion at a collection of targets
c
c      l3dformtac: creates local expansion due to
c                 a collection of charges.
c
c      l3dformtad: creates local expansion due to
c                 a collection of dipoles
c
c      l3dformtacd: creates local expansion due to
c                 a collection of charges and dipoles
c
c**********************************************************************
      subroutine l3dmpevalp(nd,rscale,center,mpole,nterms,
     1		ztarg,ntarg,pot,wlege,nlege,thresh)
c**********************************************************************
c
c
c     this subroutine evaluates the potential
c     of an outgoing multipole expansioni and adds
c     to existing quantities
c
c     pot =  pot + sum sum  mpole(n,m) Y_nm(theta,phi) / r^{n+1}
c                   n   m
c
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    multipole expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target location
c     ntarg  :    number of target locations
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c     thresh :    threshold for computing outgoing expansion,
c                 potential at target location
c                 won't be updated if |t-c| <= thresh, where
c                 t is the target location and c is the expansion
c                 center location
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :   updated potential at ztarg
c
c----------------------------------------------------------------------
      implicit none

c
cc     calling sequence variables
c

      integer nterms,nlege,ntarg,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      real *8 pot(nd,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(0:nlege,0:nlege), thresh

c
cc     temporary variables
c

      integer idim
      real *8, allocatable :: ynm(:,:),fr(:)
      complex *16, allocatable :: ephi(:)
      integer i,j,k,l,m,n,itarg
      real *8 done,r,theta,phi,zdiff(3)
      real *8 ctheta,stheta,cphi,sphi
      real *8 d,rs,rtmp1,rtmp2
      complex *16 ephi1
c
      complex *16 eye
c
      data eye/(0.0d0,1.0d0)/
c
      done=1.0d0

      allocate(ephi(0:nterms+1))
      allocate(fr(0:nterms+1))
      allocate(ynm(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)

        if(abs(r).lt.thresh) goto 1000

        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        d = 1.0d0/r
        fr(0) = d
        d = d*rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
        enddo
c
c    get the associated Legendre functions:
c

        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
        do l = 0,nterms
          rs = sqrt(1.0d0/(2*l+1))
          do m=0,l
            ynm(l,m) = ynm(l,m)*rs
          enddo
        enddo

        do idim=1,nd
          pot(idim,itarg) = pot(idim,itarg) +
     1                 real(mpole(idim,0,0))*fr(0)
        enddo
        do n=1,nterms
          rtmp1 = fr(n)*ynm(n,0)
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+real(mpole(idim,n,0))*rtmp1
          enddo
	      do m=1,n
            rtmp1 = fr(n)*ynm(n,m)
            do idim=1,nd
              rtmp2 = 2*real(mpole(idim,n,m)*ephi(m))
              pot(idim,itarg)=pot(idim,itarg)+rtmp1*rtmp2
            enddo
          enddo
        enddo
 1000 continue
      enddo

      return
      end
c
c
c
c**********************************************************************
      subroutine l3dmpevalg(nd,rscale,center,mpole,nterms,
     1		ztarg,ntarg,pot,grad,wlege,nlege,thresh)
c**********************************************************************
c
c
c     this subroutine evaluates the potential and gradient of
c     of an outgoing multipole expansioni and adds
c     to existing quantities
c
c     pot =  pot + sum sum  mpole(n,m) Y_nm(theta,phi) / r^{n+1}
c                   n   m
c
c     grad =  grad + Gradient( sum sum  mpole(n,m) Y_nm(theta,phi)/r^{n+1})
c                               n   m
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    multipole expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target location
c     ntarg  :    number of target locations
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c     thresh :    threshold for computing outgoing expansion,
c                 potential and gradient at target location
c                 won't be updated if |t-c| <= thresh, where
c                 t is the target location and c is the expansion
c                 center location
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :   updated potential at ztarg
c     grad   :   updated gradient at ztarg
c
c----------------------------------------------------------------------
      implicit none

c
cc     calling sequence variables
c

      integer nterms,nlege,ntarg,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      real *8 pot(nd,ntarg),grad(nd,3,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(0:nlege,0:nlege), thresh

c
cc     temporary variables
c
      integer idim
      real *8, allocatable :: ynm(:,:),ynmd(:,:),fr(:),frder(:)
      complex *16, allocatable :: ephi(:)
      integer i,j,k,l,m,n,itarg
      real *8 done,r,theta,phi,zdiff(3)
      real *8 ctheta,stheta,cphi,sphi
      real *8 d,rx,ry,rz,thetax,thetay,thetaz,phix,phiy,phiz,rs
      real *8 rtmp1,rtmp2,rtmp3,rtmp4,rtmp5,rtmp6
      complex *16 ephi1
      real *8 ur(nd),utheta(nd),uphi(nd)
c
      complex *16 eye
c
      data eye/(0.0d0,1.0d0)/
c
      done=1.0d0

      allocate(ephi(0:nterms+1))
      allocate(fr(0:nterms+1),frder(0:nterms))
      allocate(ynm(0:nterms,0:nterms))
      allocate(ynmd(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)

        if(abs(r).lt.thresh) goto 1000

        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        d = 1.0d0/r
        fr(0) = d
        d = d*rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
        enddo
        do i=0,nterms
          frder(i) = -(i+1.0d0)*fr(i+1)/rscale
        enddo
c
c    get the associated Legendre functions:
c

        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do l = 0,nterms
          rs = sqrt(1.0d0/(2*l+1))
          do m=0,l
            ynm(l,m) = ynm(l,m)*rs
            ynmd(l,m) = ynmd(l,m)*rs
          enddo
        enddo

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r
        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r
        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0

        do idim=1,nd
          ur(idim) = real(mpole(idim,0,0))*frder(0)
          utheta(idim) = 0.0d0
          uphi(idim) = 0.0d0
          pot(idim,itarg) = pot(idim,itarg) +
     1        real(mpole(idim,0,0))*fr(0)
        enddo

        do n=1,nterms
          rtmp1 = fr(n)*ynm(n,0)
          rtmp2 = frder(n)*ynm(n,0)
          rtmp3 = -fr(n)*ynmd(n,0)*stheta
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+real(mpole(idim,n,0))*rtmp1
            ur(idim)=ur(idim)+real(mpole(idim,n,0))*rtmp2
            utheta(idim)=utheta(idim)+real(mpole(idim,n,0))*rtmp3
          enddo

	      do m=1,n
            rtmp1 = fr(n)*ynm(n,m)*stheta
            rtmp4 = frder(n)*ynm(n,m)*stheta
            rtmp5 = -fr(n)*ynmd(n,m)
            rtmp6 = -m*fr(n)*ynm(n,m)

            do idim=1,nd
              rtmp2 = 2*real(mpole(idim,n,m)*ephi(m))

              pot(idim,itarg)=pot(idim,itarg)+rtmp1*rtmp2
              ur(idim) = ur(idim) + rtmp4*rtmp2
              utheta(idim) = utheta(idim)+rtmp5*rtmp2
              rtmp2 = 2*imag(mpole(idim,n,m)*ephi(m))
              uphi(idim) = uphi(idim) + rtmp6*rtmp2
            enddo
          enddo
        enddo

        do idim=1,nd
          grad(idim,1,itarg)=grad(idim,1,itarg)+ur(idim)*rx+
     1          utheta(idim)*thetax+uphi(idim)*phix
          grad(idim,2,itarg)=grad(idim,2,itarg)+ur(idim)*ry+
     1          utheta(idim)*thetay+uphi(idim)*phiy
          grad(idim,3,itarg)=grad(idim,3,itarg)+ur(idim)*rz+
     1          utheta(idim)*thetaz+uphi(idim)*phiz
        enddo

 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformmpc(nd,rscale,sources,charge,ns,center,
     1                  nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs multipole expansion about CENTER due to NS charges
C     located at SOURCES(3,*) and add to existing expansions
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(nd,ns)   : charge strengths
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the multipole expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 charge(nd,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:)
      real *8 theta,stheta,ctheta,phi,sphi,cphi,dtmp,d,r
      complex *16, allocatable :: ephi(:)
      complex *16 ephi1
      complex *16 eye
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        fr(0) = 1.0d0
        d = r/rscale
        fr(1) = d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo

c
c     get the associated Legendre functions and rescale
c      by 1/sqrt(2*l+1)
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c          \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)  / (|T|)^{n+1}
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        do idim=1,nd
          mpole(idim,0,0)= mpole(idim,0,0) + fr(0)*charge(idim,isrc)
        enddo
        do n=1,nterms
          dtmp=ynm(n,0)*fr(n)
          do idim=1,nd
            mpole(idim,n,0)= mpole(idim,n,0) + dtmp*charge(idim,isrc)
          enddo
          do m=1,n
            dtmp=ynm(n,m)*fr(n)
            do idim=1,nd
              mpole(idim,n,m) = mpole(idim,n,m) +
     1                  dtmp*ephi(-m)*charge(idim,isrc)
              mpole(idim,n,-m) = mpole(idim,n,-m) +
     1                  dtmp*ephi(m)*charge(idim,isrc)
            enddo
          enddo
        enddo
      enddo
c
c
      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformmpd(nd,rscale,sources,dipvec,ns,center,
     1                  nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs multipole expansion about CENTER due to NS dipoles
C     located at SOURCES(3,*) and adds to existing expansion
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     dipvec(nd,3,ns) : dipole orientiation vectors
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the multipole expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 dipvec(nd,3,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:),frder(:),ynmd(:,:)
      real *8 thetaz,thetay,thetax, theta
      real *8 stheta,sphi,rx,ry,rz,r
      real *8 ctheta,cphi
      real *8 phix,phiy,phiz,phi,fruse,d

      complex *16 ur,utheta,uphi,ux,uy,uz,zzz
      complex *16, allocatable :: ephi(:)
      complex *16 eye,ephi1
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(frder(0:nterms),ynmd(0:nterms,0:nterms))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        fr(0) = 1.0d0
        d = r/rscale
        fr(1) = d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
        frder(0) = 0.0d0
        do i=1,nterms
          frder(i) = i*fr(i-1)/rscale
        enddo
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c     In thetax, thetaty, phix, phiy we leave out the 1/r factors in the
c     change of variables to avoid blow-up at the origin.
c     For the n=0 mode, it is not relevant. For n>0 modes,
c     the variable fruse is set to fr(n)/r:
c
c
c
        rx = stheta*cphi
        thetax = ctheta*cphi
        phix = -sphi
        ry = stheta*sphi
        thetay = ctheta*sphi
        phiy = cphi
        rz = ctheta
        thetaz = -stheta
        phiz = 0.0d0
c
c     get the associated Legendre functions and rescale by
c       1/sqrt(2*l+1)
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
            ynmd(j,i) = ynmd(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c         \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)/ (|T|^(n+1))
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        ur = ynm(0,0)*frder(0)
        ux = ur*rx
        uy = ur*ry
        uz = ur*rz
        do idim=1,nd
          zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
          mpole(idim,0,0)= mpole(idim,0,0) + zzz
        enddo

        do n=1,nterms
          fruse = fr(n-1)/rscale
          ur = ynm(n,0)*frder(n)
          utheta = -fruse*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + zzz
          enddo
          do m=1,n
            ur = frder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fruse*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fruse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,m)= mpole(idim,n,m) + zzz
            enddo
c
            ur = frder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fruse*ynmd(n,m)
            uphi = eye*m*ephi(m)*fruse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m) + zzz
            enddo
          enddo
        enddo
      enddo
c
      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformmpcd(nd,rscale,sources,charge,dipvec,ns,
     1             center,nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs multipole expansion about CENTER due to NS charges+dipoles
C     located at SOURCES(3,*) and adds to existing expansion
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(nd,ns)   : charge strengths
C     dipvec(nd,3,ns) : dipole orientiation vectors
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the multipole expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 charge(nd,ns)
      real *8 dipvec(nd,3,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:),frder(:),ynmd(:,:)
      real *8 thetaz,thetay,thetax, theta
      real *8 stheta,sphi,rx,ry,rz,r
      real *8 ctheta,cphi
      real *8 phix,phiy,phiz,phi,fruse,d,dtmp

      complex *16 ur,utheta,uphi,ux,uy,uz,zzz
      complex *16, allocatable :: ephi(:)
      complex *16 eye,ephi1
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(frder(0:nterms),ynmd(0:nterms,0:nterms))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        fr(0) = 1.0d0
        d = r/rscale
        fr(1) = d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
        frder(0) = 0.0d0
        do i=1,nterms
          frder(i) = i*fr(i-1)/rscale
        enddo
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c     In thetax, thetaty, phix, phiy we leave out the 1/r factors in the
c     change of variables to avoid blow-up at the origin.
c     For the n=0 mode, it is not relevant. For n>0 modes,
c     the variable fruse is set to fr(n)/r:
c
c
c
        rx = stheta*cphi
        thetax = ctheta*cphi
        phix = -sphi
        ry = stheta*sphi
        thetay = ctheta*sphi
        phiy = cphi
        rz = ctheta
        thetaz = -stheta
        phiz = 0.0d0
c
c     get the associated Legendre functions and rescale by
c       1/sqrt(2*l+1)
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
            ynmd(j,i) = ynmd(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c         \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)/ (|T|^(n+1))
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        ur = ynm(0,0)*frder(0)
        ux = ur*rx
        uy = ur*ry
        uz = ur*rz
        do idim=1,nd
          zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
          mpole(idim,0,0)= mpole(idim,0,0) + zzz +
     1            fr(0)*charge(idim,isrc)
        enddo

        do n=1,nterms
          fruse = fr(n-1)/rscale
          ur = ynm(n,0)*frder(n)
          utheta = -fruse*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          dtmp = fr(n)*ynm(n,0)
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + zzz +
     1         charge(idim,isrc)*dtmp
          enddo
          do m=1,n
            ur = frder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fruse*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fruse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            dtmp = ynm(n,m)*fr(n)*stheta
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,m)= mpole(idim,n,m) + zzz +
     1            charge(idim,isrc)*dtmp*ephi(-m)
            enddo
c
            ur = frder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fruse*ynmd(n,m)
            uphi = eye*m*ephi(m)*fruse*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m)+zzz+
     1              charge(idim,isrc)*dtmp*ephi(m)
            enddo
          enddo
        enddo
      enddo
c
      return
      end
c
c
c
c
c
c
c**********************************************************************
      subroutine l3dtaevalp(nd,rscale,center,mpole,nterms,
     1		ztarg,ntarg,pot,wlege,nlege)
c**********************************************************************
c
c
c     this subroutine evaluates the potential
c     of an incoming multipole expansioni and adds
c     to existing quantities
c
c     pot =  pot + sum sum  r^{n} mpole(n,m) Y_nm(theta,phi) /sqrt(2n+1)
c                   n   m
c
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    local expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target location
c     ntarg  :    number of target locations
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :   updated potential at ztarg
c
c----------------------------------------------------------------------
      implicit none

c
cc     calling sequence variables
c

      integer nterms,nlege,ntarg,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      real *8 pot(nd,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(0:nlege,0:nlege), thresh

c
cc     temporary variables
c

      integer idim
      real *8, allocatable :: ynm(:,:),fr(:)
      complex *16, allocatable :: ephi(:)
      integer i,j,k,l,m,n,itarg
      real *8 done,r,theta,phi,zdiff(3)
      real *8 ctheta,stheta,cphi,sphi
      real *8 d,rs,rtmp1,rtmp2
      complex *16 ephi1
c
      complex *16 eye
c
      data eye/(0.0d0,1.0d0)/
c
      done=1.0d0

      allocate(ephi(0:nterms+1))
      allocate(fr(0:nterms+1))
      allocate(ynm(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)

        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        cphi = dreal(ephi1)
        sphi = dimag(ephi1)
        fr(0) = 1.0d0
        d = r/rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
        enddo
c
c    get the associated Legendre functions:
c

        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
        do l = 0,nterms
          rs = sqrt(1.0d0/(2*l+1))
          do m=0,l
            ynm(l,m) = ynm(l,m)*rs
          enddo
        enddo

        do idim=1,nd
          pot(idim,itarg) = pot(idim,itarg) +
     1        real(mpole(idim,0,0))*fr(0)
        enddo
        do n=1,nterms
          rtmp1 = fr(n)*ynm(n,0)
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+real(mpole(idim,n,0))*rtmp1
          enddo
	      do m=1,n
            rtmp1 = fr(n)*ynm(n,m)
            do idim=1,nd
              rtmp2 = 2*real(mpole(idim,n,m)*ephi(m))
              pot(idim,itarg)=pot(idim,itarg)+rtmp1*rtmp2
            enddo
          enddo
        enddo
      enddo

      return
      end
c
c
c
c**********************************************************************
      subroutine l3dtaevalg(nd,rscale,center,mpole,nterms,
     1		ztarg,ntarg,pot,grad,wlege,nlege)
c**********************************************************************
c
c
c     this subroutine evaluates the potential and gradient of
c     of an local multipole expansioni and adds
c     to existing quantities
c
c     pot =  pot + sum sum  mpole(n,m) r^{n}Y_nm(theta,phi) / sqrt(2n+1)
c                   n   m
c
c     grad =  grad + Gradient( sum sum mpole(n,m)r^{n}Y_nm(theta,phi)/sqrt(2n+1))
c                               n   m
c
c-----------------------------------------------------------------------
c     INPUT:
c
c     nd     :    number of multipole expansions
c     rscale :    scaling parameter
c     center :    expansion center
c     mpole  :    local expansion
c     nterms :    order of the multipole expansion
c     ztarg  :    target location
c     ntarg  :    number of target locations
c     wlege  :    precomputed array of scaling coeffs for Pnm
c     nlege  :    dimension parameter for wlege
c-----------------------------------------------------------------------
c     OUTPUT:
c
c     pot    :   updated potential at ztarg
c     grad   :   updated gradient at ztarg
c
c----------------------------------------------------------------------
      implicit none

c
cc     calling sequence variables
c

      integer nterms,nlege,ntarg,nd
      real *8 rscale,center(3),ztarg(3,ntarg)
      real *8 pot(nd,ntarg),grad(nd,3,ntarg)
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 wlege(0:nlege,0:nlege)

c
cc     temporary variables
c
      integer idim
      real *8, allocatable :: ynm(:,:),ynmd(:,:),fr(:),frder(:)
      complex *16, allocatable :: ephi(:)
      integer i,j,k,l,m,n,itarg
      real *8 done,r,theta,phi,zdiff(3)
      real *8 ctheta,stheta,cphi,sphi
      real *8 d,rx,ry,rz,thetax,thetay,thetaz,phix,phiy,phiz,rs
      real *8 rtmp1,rtmp2,rtmp3,rtmp4,rtmp5,rtmp6
      complex *16 ephi1
      real *8 ur(nd),utheta(nd),uphi(nd)
c
      complex *16 eye
      complex *16 ztmp1,ztmp2,ztmp3,ztmpsum,z
c
      data eye/(0.0d0,1.0d0)/
c
      done=1.0d0

      allocate(ephi(0:nterms+1))
      allocate(fr(0:nterms+1),frder(0:nterms))
      allocate(ynm(0:nterms,0:nterms))
      allocate(ynmd(0:nterms,0:nterms))

      do itarg=1,ntarg
        zdiff(1)=ztarg(1,itarg)-center(1)
        zdiff(2)=ztarg(2,itarg)-center(2)
        zdiff(3)=ztarg(3,itarg)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)

        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array
c
        ephi(0)=done
        ephi(1)=ephi1
        d = r/rscale
        fr(0) = 1.0d0
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
        enddo
        frder(0) = 0
        do i=1,nterms
          frder(i) = i*fr(i-1)/rscale
        enddo
c
c    get the associated Legendre functions:
c

        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do l = 0,nterms
          rs = sqrt(1.0d0/(2*l+1))
          do m=0,l
            ynm(l,m) = ynm(l,m)*rs
            ynmd(l,m) = ynmd(l,m)*rs
          enddo
        enddo

c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c
c     NOTE: sphereical derivative needs to be fixed for r=0
c
c
        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r
        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r
        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0

        do idim=1,nd
          ur(idim) = real(mpole(idim,0,0))*frder(0)
          utheta(idim) = 0.0d0
          uphi(idim) = 0.0d0
          pot(idim,itarg) = pot(idim,itarg)+real(mpole(idim,0,0))*fr(0)
        enddo

        do n=1,nterms
          rtmp1 = fr(n)*ynm(n,0)
          rtmp2 = frder(n)*ynm(n,0)
          rtmp3 = -fr(n)*ynmd(n,0)*stheta
          do idim=1,nd
            pot(idim,itarg)=pot(idim,itarg)+real(mpole(idim,n,0))*rtmp1
            ur(idim)=ur(idim)+real(mpole(idim,n,0))*rtmp2
            utheta(idim)=utheta(idim)+real(mpole(idim,n,0))*rtmp3
          enddo

	      do m=1,n
            rtmp1 = fr(n)*ynm(n,m)*stheta
            rtmp4 = frder(n)*ynm(n,m)*stheta
            rtmp5 = -fr(n)*ynmd(n,m)
            rtmp6 = -m*fr(n)*ynm(n,m)

            do idim=1,nd
              rtmp2 = 2*real(mpole(idim,n,m)*ephi(m))

              pot(idim,itarg)=pot(idim,itarg)+rtmp1*rtmp2
              ur(idim) = ur(idim) + rtmp4*rtmp2
              utheta(idim) = utheta(idim)+rtmp5*rtmp2
              rtmp2 = 2*imag(mpole(idim,n,m)*ephi(m))
              uphi(idim) = uphi(idim) + rtmp6*rtmp2
            enddo
          enddo
        enddo

        do idim=1,nd
          grad(idim,1,itarg)=grad(idim,1,itarg)+ur(idim)*rx+
     1          utheta(idim)*thetax+uphi(idim)*phix
          grad(idim,2,itarg)=grad(idim,2,itarg)+ur(idim)*ry+
     1          utheta(idim)*thetay+uphi(idim)*phiy
          grad(idim,3,itarg)=grad(idim,3,itarg)+ur(idim)*rz+
     1          utheta(idim)*thetaz+uphi(idim)*phiz
        enddo

 1000 continue
      enddo

      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformtac(nd,rscale,sources,charge,ns,center,
     1                  nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs local expansion about CENTER due to NS charges
C     located at SOURCES(3,*) and add to existing expansions
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(nd,ns)   : charge strengths
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the local expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 charge(nd,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:)
      real *8 theta,stheta,ctheta,phi,sphi,cphi,dtmp,d,r
      complex *16, allocatable :: ephi(:)
      complex *16 ephi1
      complex *16 eye
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        d = 1.0d0/r
        fr(0) = d
        d = d*rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo

c
c     get the associated Legendre functions and rescale
c      by 1/sqrt(2*l+1)
c
        call ylgndrfw(nterms,ctheta,ynm,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c          \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)  / (|T|)^{n+1}
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        do idim=1,nd
          mpole(idim,0,0)= mpole(idim,0,0) + fr(0)*charge(idim,isrc)
        enddo
        do n=1,nterms
          dtmp=ynm(n,0)*fr(n)
          do idim=1,nd
            mpole(idim,n,0)= mpole(idim,n,0) + dtmp*charge(idim,isrc)
          enddo
          do m=1,n
            dtmp=ynm(n,m)*fr(n)
            do idim=1,nd
              mpole(idim,n,m) = mpole(idim,n,m) +
     1                  dtmp*ephi(-m)*charge(idim,isrc)
              mpole(idim,n,-m) = mpole(idim,n,-m) +
     1                  dtmp*ephi(m)*charge(idim,isrc)
            enddo
          enddo
        enddo
      enddo
c
c
      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformtad(nd,rscale,sources,dipvec,ns,center,
     1                  nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs multipole expansion about CENTER due to NS dipoles
C     located at SOURCES(3,*) and adds to existing expansion
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     dipvec(nd,3,ns) : dipole orientiation vectors
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the multipole expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 dipvec(nd,3,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:),frder(:),ynmd(:,:)
      real *8 thetaz,thetay,thetax, theta
      real *8 stheta,sphi,rx,ry,rz,r
      real *8 ctheta,cphi
      real *8 phix,phiy,phiz,phi,d

      complex *16 ur,utheta,uphi,ux,uy,uz,zzz
      complex *16, allocatable :: ephi(:)
      complex *16 eye,ephi1
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(frder(0:nterms),ynmd(0:nterms,0:nterms))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        d = 1.0d0/r
        fr(0) = d
        d = d*rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
        do i=0,nterms
          frder(i) = -(i+1.0d0)*fr(i+1)/rscale
        enddo
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c
        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r
        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r
        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0
c
c     get the associated Legendre functions and rescale by
c       1/sqrt(2*l+1)
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
            ynmd(j,i) = ynmd(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c         \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)/ (|T|^(n+1))
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        ur = ynm(0,0)*frder(0)
        ux = ur*rx
        uy = ur*ry
        uz = ur*rz
        do idim=1,nd
          zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
          mpole(idim,0,0)= mpole(idim,0,0) + zzz
        enddo

        do n=1,nterms
          ur = ynm(n,0)*frder(n)
          utheta = -fr(n)*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + zzz
          enddo
          do m=1,n
            ur = frder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fr(n)*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fr(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,m)= mpole(idim,n,m) + zzz
            enddo
c
            ur = frder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fr(n)*ynmd(n,m)
            uphi = eye*m*ephi(m)*fr(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m) + zzz
            enddo
          enddo
        enddo
      enddo
c
      return
      end
c
c
c
c
c
c
c
C***********************************************************************
      subroutine l3dformtacd(nd,rscale,sources,charge,dipvec,ns,
     1             center,nterms,mpole,wlege,nlege)
C***********************************************************************
C
C     Constructs multipole expansion about CENTER due to NS charges+dipoles
C     located at SOURCES(3,*) and adds to existing expansion
C
c-----------------------------------------------------------------------
C     INPUT:
c
c     nd              : number of multipole expansions
C     rscale          : the scaling factor.
C     sources(3,ns)   : coordinates of sources
C     charge(nd,ns)   : charge strengths
C     dipvec(nd,3,ns) : dipole orientiation vectors
C     ns              : number of sources
C     center(3)       : epxansion center
C     nterms          : order of multipole expansion
C     wlege           : precomputed array of scaling coeffs for pnm
C     nlege           : dimension parameter for wlege
c-----------------------------------------------------------------------
C     OUTPUT:
C
c     mpole           : coeffs of the multipole expansion
c-----------------------------------------------------------------------
      implicit none
c
cc       calling sequence variables
c

      integer nterms,ns,nd, nlege
      real *8 center(3),sources(3,ns)
      real *8 wlege(0:nlege,0:nlege)
      real *8 rscale
      complex *16 mpole(nd,0:nterms,-nterms:nterms)
      real *8 charge(nd,ns)
      real *8 dipvec(nd,3,ns)

c
cc       temporary variables
c

      integer i,j,k,l,m,n,isrc,idim
      real *8 zdiff(3)
      real *8, allocatable :: ynm(:,:),fr(:),rfac(:),frder(:),ynmd(:,:)
      real *8 thetaz,thetay,thetax, theta
      real *8 stheta,sphi,rx,ry,rz,r
      real *8 ctheta,cphi
      real *8 phix,phiy,phiz,phi,fruse,d,dtmp

      complex *16 ur,utheta,uphi,ux,uy,uz,zzz
      complex *16, allocatable :: ephi(:)
      complex *16 eye,ephi1
      data eye/(0.0d0,1.0d0)/

      allocate(ynm(0:nterms,0:nterms),fr(0:nterms+1))
      allocate(frder(0:nterms),ynmd(0:nterms,0:nterms))
      allocate(ephi(-nterms-1:nterms+1))
      allocate(rfac(0:nterms))

      do i=0,nterms
        rfac(i) = 1/sqrt(2.0d0*i + 1.0d0)
      enddo

      do isrc = 1,ns
        zdiff(1)=sources(1,isrc)-center(1)
        zdiff(2)=sources(2,isrc)-center(2)
        zdiff(3)=sources(3,isrc)-center(3)
c
        call cart2polar(zdiff,r,theta,phi)
        ctheta = dcos(theta)
        stheta = dsin(theta)
        cphi = dcos(phi)
        sphi = dsin(phi)
        ephi1 = dcmplx(cphi,sphi)
c
c     compute exp(eye*m*phi) array and fr array
c
        ephi(0)=1.0d0
        ephi(1)=ephi1
        ephi(-1)=dconjg(ephi1)
        d = 1.0d0/r
        fr(0) = d
        d = d*rscale
        fr(1) = fr(0)*d
        do i=2,nterms+1
          fr(i) = fr(i-1)*d
          ephi(i)=ephi(i-1)*ephi1
          ephi(-i)=ephi(-i+1)*ephi(-1)
        enddo
        do i=0,nterms
          frder(i) = -(i+1.0d0)*fr(i+1)/rscale
        enddo
c
c     compute coefficients in change of variables from spherical
c     to Cartesian gradients. In phix, phiy, we leave out the
c     1/sin(theta) contribution, since we use values of Ynm (which
c     multiplies phix and phiy) that are scaled by
c     1/sin(theta).
c
c     In thetax, thetaty, phix, phiy we leave out the 1/r factors in the
c     change of variables to avoid blow-up at the origin.
c     For the n=0 mode, it is not relevant. For n>0 modes,
c     the variable fruse is set to fr(n)/r:
c
c
c
        rx = stheta*cphi
        thetax = ctheta*cphi/r
        phix = -sphi/r
        ry = stheta*sphi
        thetay = ctheta*sphi/r
        phiy = cphi/r
        rz = ctheta
        thetaz = -stheta/r
        phiz = 0.0d0
c
c     get the associated Legendre functions and rescale by
c       1/sqrt(2*l+1)
c
        call ylgndr2sfw(nterms,ctheta,ynm,ynmd,wlege,nlege)
        do i=0,nterms
          do j=0,nterms
            ynm(j,i) = ynm(j,i)*rfac(j)
            ynmd(j,i) = ynmd(j,i)*rfac(j)
          enddo
        enddo
c
c
c     Compute contribution to mpole coefficients.
c
c     Recall that there are multiple definitions of scaling for
c     Ylm. Using our standard definition,
c     the addition theorem takes the simple form
c
c        1/r =
c         \sum_n 1/(2n+1) \sum_m  |S|^n Ylm*(S) Ylm(T)/ (|T|^(n+1))
c
c     so contribution is |S|^n times
c
c       Ylm*(S)  = P_l,m * dconjg(ephi(m))               for m > 0
c       Yl,m*(S)  = P_l,|m| * dconjg(ephi(m))            for m < 0
c
c       where P_l,m is the scaled associated Legendre function.
c
c
        ur = ynm(0,0)*frder(0)
        ux = ur*rx
        uy = ur*ry
        uz = ur*rz
        do idim=1,nd
          zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
          mpole(idim,0,0)= mpole(idim,0,0) + zzz +
     1            fr(0)*charge(idim,isrc)
        enddo

        do n=1,nterms
          ur = ynm(n,0)*frder(n)
          utheta = -fr(n)*ynmd(n,0)*stheta
          ux = ur*rx + utheta*thetax
          uy = ur*ry + utheta*thetay
          uz = ur*rz + utheta*thetaz
          dtmp = fr(n)*ynm(n,0)
          do idim=1,nd
            zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1        dipvec(idim,3,isrc)*uz
            mpole(idim,n,0)= mpole(idim,n,0) + zzz +
     1         charge(idim,isrc)*dtmp
          enddo
          do m=1,n
            ur = frder(n)*ynm(n,m)*stheta*ephi(-m)
            utheta = -ephi(-m)*fr(n)*ynmd(n,m)
            uphi = -eye*m*ephi(-m)*fr(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            dtmp = ynm(n,m)*fr(n)*stheta
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,m)= mpole(idim,n,m) + zzz+
     1            charge(idim,isrc)*dtmp*ephi(-m)
            enddo
c
            ur = frder(n)*ynm(n,m)*stheta*ephi(m)
            utheta = -ephi(m)*fr(n)*ynmd(n,m)
            uphi = eye*m*ephi(m)*fr(n)*ynm(n,m)
            ux = ur*rx + utheta*thetax + uphi*phix
            uy = ur*ry + utheta*thetay + uphi*phiy
            uz = ur*rz + utheta*thetaz + uphi*phiz
            do idim=1,nd
              zzz = dipvec(idim,1,isrc)*ux + dipvec(idim,2,isrc)*uy +
     1          dipvec(idim,3,isrc)*uz
              mpole(idim,n,-m)= mpole(idim,n,-m)+zzz+
     1              charge(idim,isrc)*dtmp*ephi(m)
            enddo
          enddo
        enddo
      enddo
c
      return
      end


!-----subroutine---------------------------------------------g.guidati--
!
COMPLEX(DbKi)  function HANK1   (x)
!
!-----------------------------------------------------------------------
!
!     franco guidati    IAG
!                       Uni Stuttgart
!
!
!     scope             calculate the first derivative of the
!                       hankel function
!
!     input             square of the argument k*r
!
!     output            H1/r
!
!.......................................................................
!               declarations
!.......................................................................
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.
REAL(DbKi)                   :: J1, Y1 , x,x2,x4, dsi, dco
REAL(DbKi),EXTERNAL          :: BESSJ1,BESSY1

!.......................................................................
!
!.......................................................................

      if(x.ge.64.0d0) then
        x2 = dsqrt(DBLE(x))
        x4 = dsqrt(DBLE(x2))
        dsi = dsin(DBLE(x2)-2.356194490192345)
        dco = dcos(DBLE(x2)-2.356194490192345)
      endif
      J1 = BESSJ1(x,x2,x4,dsi,dco)
      Y1 = BESSY1(x,x2,x4,J1,dsi,dco)

      HANK1 = J1 + (0.0d0,1.0d0) * Y1

!.......................................................................
!               end of function
!.......................................................................
     return
!***********************************************************************
      end function

REAL(DbKi) FUNCTION bessj1(x,x2,x4,dsi,dco)
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

REAL(DbKi)                   :: x,x2,x4,dsi,dco
REAL(DbKi)                   :: ax,xx,z,pp,y
REAL(DbKi),SAVE              :: p1 = 1.0d0
REAL(DbKi),SAVE              :: p2 = .183105d-2
REAL(DbKi),SAVE              :: p3 = -.3516396496d-4
REAL(DbKi),SAVE              :: p4 = .2457520174d-5
REAL(DbKi),SAVE              :: p5 = -.240337019d-6
REAL(DbKi),SAVE              :: q1 = .04687499995d0
REAL(DbKi),SAVE              :: q2 = -.2002690873d-3
REAL(DbKi),SAVE              :: q3 = .8449199096d-5
REAL(DbKi),SAVE              :: q4 = -.88228987d-6
REAL(DbKi),SAVE              :: q5 = .105787412d-6
REAL(DbKi),SAVE              :: r1 = 72362614232.d0
REAL(DbKi),SAVE              :: r2 = -7895059235.d0
REAL(DbKi),SAVE              :: r3 = 242396853.1d0
REAL(DbKi),SAVE              :: r4 = -2972611.439d0
REAL(DbKi),SAVE              :: r5 = 15704.48260d0
REAL(DbKi),SAVE              :: r6 = -30.16036606d0
REAL(DbKi),SAVE              :: s1 = 144725228442.d0
REAL(DbKi),SAVE              :: s2 = 2300535178.d0
REAL(DbKi),SAVE              :: s3 = 18583304.74d0
REAL(DbKi),SAVE              :: s4 = 99447.43394d0
REAL(DbKi),SAVE              :: s5 = 376.9991397d0
REAL(DbKi),SAVE              :: s6 = 1.d0

      if(abs(x).lt.64.)then
        y=x
        bessj1=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y*(s4+y*(s5+y*s6)))))
      else
        ax=abs(x2)
        z=8./ax
        y=z**2
!        xx=ax-2.356194491
        bessj1=0.7978845608028654/x4*(dco*(p1+y*(p2+y*(p3+y*(p4+y*p5)))) &
               -z*dsi*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*dsign(1.0d0,DBLE(x2))/x2
      endif
      return
      END FUNCTION

REAL(DbKi) FUNCTION bessy1(x,x2,x4,J1,dsi,dco)
      USE TIPrecision

IMPLICIT                        NONE

   ! Local variables.

REAL(DbKi)                   :: x,x2,x4,J1,dsi,dco
REAL(DbKi)                   :: ax,xx,z,pp,y
REAL(DbKi),SAVE              :: p1 = 1.0d0
REAL(DbKi),SAVE              :: p2 = .183105d-2
REAL(DbKi),SAVE              :: p3 = -.3516396496d-4
REAL(DbKi),SAVE              :: p4 = .2457520174d-5
REAL(DbKi),SAVE              :: p5 = -.240337019d-6
REAL(DbKi),SAVE              :: q1 = .04687499995d0
REAL(DbKi),SAVE              :: q2 = -.2002690873d-3
REAL(DbKi),SAVE              :: q3 = .8449199096d-5
REAL(DbKi),SAVE              :: q4 = -.88228987d-6
REAL(DbKi),SAVE              :: q5 = .105787412d-6
REAL(DbKi),SAVE              :: r1 = -.4900604943d13
REAL(DbKi),SAVE              :: r2 = .1275274390d13
REAL(DbKi),SAVE              :: r3 = -.5153438139d11
REAL(DbKi),SAVE              :: r4 = .7349264551d9
REAL(DbKi),SAVE              :: r5 = -.4237922726d7
REAL(DbKi),SAVE              :: r6 = .8511937935d4
REAL(DbKi),SAVE              :: s1 = .2499580570d14
REAL(DbKi),SAVE              :: s2 = .4244419664d12
REAL(DbKi),SAVE              :: s3 = .3733650367d10
REAL(DbKi),SAVE              :: s4 = .2245904002d8
REAL(DbKi),SAVE              :: s5 = .1020426050d6
REAL(DbKi),SAVE              :: s6 = .3549632885d3
REAL(DbKi),SAVE              :: s7 = 1.d0

!U    USES bessj1

      if(x.lt.64.)then
        y=x
        bessy1=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+  &
                y*(s4+y*(s5+y*(s6+y*s7))))))+.636619772*(J1*0.5*dlog(DBLE(y))-1./y)
      else
        z=8./x2
        y=z**2.0
!        xx=x2-2.356194491
        bessy1=0.7978845608028654/x4*(dsi*(p1+y*(p2+y*(p3+y*(p4+y*  &
               p5))))+z*dco*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))/x2
      endif
      return
      END FUNCTION


type B = A => A -> A -> A in
let t = Fun(A){ fun(x: A){ fun(y: A){ x } } } : B in
let f = Fun(A){ fun(x: A){ fun(y: A){ y } } } : B in
type IF = A => B -> A -> A -> A in
let if = Fun(A){ fun(x: B){ fun(y: A){ fun(z: A){ x[A] y z } } } } : IF in
  if[B] t f t


      SUBROUTINE kstwo(data1,n1,data2,n2,d,prob)
      INTEGER n1,n2
      REAL d,prob,data1(n1),data2(n2)
CU    USES probks,sort
      INTEGER j1,j2
      REAL d1,d2,dt,en1,en2,en,fn1,fn2,probks
      call sort(n1,data1)
      call sort(n2,data2)
      en1=n1
      en2=n2
      j1=1
      j2=1
      fn1=0.
      fn2=0.
      d=0.
1     if(j1.le.n1.and.j2.le.n2)then
        d1=data1(j1)
        d2=data2(j2)
        if(d1.le.d2)then
          fn1=j1/en1
          j1=j1+1
        endif
        if(d2.le.d1)then
          fn2=j2/en2
          j2=j2+1
        endif
        dt=abs(fn2-fn1)
        if(dt.gt.d)d=dt
      goto 1
      endif
      en=sqrt(en1*en2/(en1+en2))
      prob=probks((en+0.12+0.11/en)*d)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/kstwo.for


subroutine interp(xnew, xold, scalefac, nsin)

      use stel_kinds, only: dp
      use name0, only: czero, c1p0, c2p0, c1pm10
      use name1, only: mpol1, nmax, mnd1
      use scalars, only: ns, hs

      implicit none

      real(kind=dp), intent(out)   ::  xnew(ns,  0:nmax,0:mpol1,6)
      real(kind=dp), intent(inout) ::  xold(nsin,0:nmax,0:mpol1,6)
      real(kind=dp), intent(in)    :: scalefac(ns,  0:nmax,0:mpol1  )
      integer,       intent(in)    :: nsin

      integer       :: ntype, js, js1, js2, n, m
      real(kind=dp) :: hsold, sj, s1, xint

      hsold = c1p0/real(nsin-1)

      do ntype = 1, 6

        ! extrapolate to axis before interpolation
        do n = 0, nmax
          xold(1,n,1,ntype) = c2p0*xold(2,n,1,ntype) - xold(3,n,1,ntype)
        end do

        ! INTERPOLATE R,Z AND LAMBDA ON FULL GRID
        do js = 1, ns

          sj = (js-1)*hs
          js1 = 1 + int(sj/hsold + c1pm10) ! TODO: why c1pm10 ?
          js2 = min(js1+1, nsin)
          s1 = (js1-1)*hsold
          xint = (sj-s1)/hsold

          do n = 0, nmax
            do m = 0, mpol1
              xnew(js,n,m,ntype) = (  (c1p0-xint)*xold(js1,n,m,ntype) &
                                    +       xint *xold(js2,n,m,ntype) ) / scalefac(js,n,m)
            end do ! m
          end do ! n
        end do ! js

        ! set interpolated axis values to zero
        do n = 0, nmax
          xnew(1,n,1,ntype) = czero
        end do ! n

      end do ! ntype

      return
end


subroutine vetoma(vecto,xmatr,ndime,ntens)
!**********************************************************************
!
!**** This routine stores a vector VECTO as a symmetric matrix XMATR
!
!**********************************************************************
  use      typre
  implicit none
  integer(ip),intent(in)   :: ndime,ntens
  real(rp),intent(out)     ::xmatr(ndime,ndime)
  real(rp),intent(in)      ::vecto(ntens)

  if(ndime.eq.2) then
        xmatr(1,1)=vecto(1)
        xmatr(1,2)=vecto(3)
        xmatr(2,1)=vecto(3)
        xmatr(2,2)=vecto(2)
   else
        xmatr(1,1)=vecto(1)
        xmatr(1,2)=vecto(4)
        xmatr(1,3)=vecto(5)
        xmatr(2,1)=vecto(4)
        xmatr(2,2)=vecto(2)
        xmatr(2,3)=vecto(6)
        xmatr(3,1)=vecto(5)
        xmatr(3,2)=vecto(6)
        xmatr(3,3)=vecto(3)
   end if

end subroutine vetoma