c
c
c       Generalized helmholtz FMM in R^3: evaluate all pairwise particle
c       interactions (ignoring self-interaction)
c       and interactions with targets
c
c       We use exp(ikr)/r for the Green's function., without
c       the 1/(4\pi ) scaling.
c
c
c-----------------------------------------------------------
        subroutine hfmm3d(nd,eps,zk,nsource,source,ifcharge,
     $    charge,ifdipole,dipvec,ifpgh,pot,grad,hess,ntarg,
     $    targ,ifpghtarg,pottarg,gradtarg,hesstarg)
c-----------------------------------------------------------------------
c   INPUT PARAMETERS:
c
c   nd:    in: integer
c             number of densities
c
c   eps:   in: double precision
c             requested precision
c
c   zk:    in: double complex
c               helmholtz parameter
c
c   nsource in: integer
c                number of sources
c
c   source  in: double precision (3,nsource)
c                source(k,j) is the kth component of the jth
c                source locations
c
c   ifcharge  in: integer
c             charge computation flag
c              ifcharge = 1   =>  include charge contribution
c                                     otherwise do not
c
c   charge    in: double complex (nd,nsource)
c              charge strengths
c
c   ifdipole   in: integer
c              dipole computation flag
c              ifdipole = 1   =>  include dipole contribution
c                                     otherwise do not
c
c   dipvec   in: double precision (nd,3,nsource)
c              dipole orientation vectors
c
c   ifpgh   in: integer
c              flag for evaluating potential/gradient at the sources
c              ifpgh = 1, only potential is evaluated
c              ifpgh = 2, potential and gradients are evaluated
c
c
c   ntarg  in: integer
c                 number of targs
c
c   targ  in: double precision (3,ntarg)
c               targ(k,j) is the kth component of the jth
c               targ location
c
c   ifpghtarg   in: integer
c              flag for evaluating potential/gradient at the targs
c              ifpghtarg = 1, only potential is evaluated
c              ifpghtarg = 2, potential and gradient are evaluated
c
c
c     OUTPUT parameters:
c
c   pot:    out: double complex(nd,nsource)
c               potential at the source locations
c
c   grad:   out: double complex(nd,3,nsource)
c               gradient at the source locations
c
c   hess    out: double complex(nd,6,nsource)
c               hessian at the source locations
c
c   pottarg:    out: double complex(nd,ntarg)
c               potential at the targ locations
c
c   gradtarg:   out: double complex(nd,3,ntarg)
c               gradient at the targ locations
c
c   hesstarg    out: double complex(nd,6,ntarg)
c                hessian at the target locations

c------------------------------------------------------------------

      implicit none

      integer nd

      double complex zk
      double precision eps

      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nsource,ntarg

      double precision source(3,nsource),targ(3,ntarg)
      double complex charge(nd,nsource)

      double complex dipvec(nd,3,nsource)

      double complex pot(nd,nsource),grad(nd,3,nsource),
     1     pottarg(nd,3,ntarg),
     1     gradtarg(nd,3,ntarg),hess(nd,6,*),hesstarg(nd,6,*)

c       Tree variables
      integer mhung,idivflag,ndiv,isep,nboxes,nbmax,nlevels
      integer *8 ltree
      integer nlmax
      integer mnbors,mnlist1,mnlist2,mnlist3,mnlist4
      integer *8 ipointer(32)
      integer, allocatable :: itree(:)
      double precision, allocatable :: treecenters(:,:),boxsize(:)
      double precision b0,b0inv,b0inv2,b0inv3
      double complex zkfmm

c
cc      temporary sorted arrays
c
      double precision, allocatable :: sourcesort(:,:),targsort(:,:)
      double precision, allocatable :: radsrc(:)
      double complex, allocatable :: chargesort(:,:)
      double complex, allocatable :: dipvecsort(:,:,:)

      double complex, allocatable :: potsort(:,:),gradsort(:,:,:),
     1       hesssort(:,:,:)
      double complex, allocatable :: pottargsort(:,:),
     1    gradtargsort(:,:,:),hesstargsort(:,:,:)

c
cc       temporary fmm arrays
c
      double precision epsfmm
      integer, allocatable :: nterms(:)
      integer *8, allocatable :: iaddr(:,:)
      double precision, allocatable :: scales(:)
      double precision, allocatable :: rmlexp(:)

      integer lmptemp,nmax
      integer *8 lmptot
      double precision, allocatable :: mptemp(:),mptemp2(:)

c
cc       temporary variables not used in particle code
c
      double precision expc(3),scjsort(1),radexp
      double complex texpssort(100)
      double precision expcsort(3),radssort(1)
      integer ntj,nexpc,nadd,ifnear

c
cc        other temporary variables
c
       integer i,iert,ifprint,ilev,idim,ier
       double precision time1,time2,omp_get_wtime,second

c
c
c     ifprint is an internal information printing flag.
c     Suppressed if ifprint=0.
c     Prints timing breakdown and other things if ifprint=1.
c
      ifprint=0

c
cc       figure out tree structure
c

c
cc        set criterion for box subdivision
c

c
c       turn on computation of list 1
c
      ifnear = 1

      call hndiv(eps,nsource,ntarg,ifcharge,ifdipole,ifpgh,
     1   ifpghtarg,ndiv,idivflag)

c
cc         set tree flags
c
       isep = 1
       nlmax = 200
       nlevels = 0
       nboxes = 0
       mhung = 0
       ltree = 0

       nexpc = 0
       nadd = 0
       ntj = 0

       mnlist1 = 0
       mnlist2 = 0
       mnlist3 = 0
       mnlist4 = 0
       nbmax = 0

       allocate(radsrc(nsource))
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
       do i=1,nsource
           radsrc(i) = 0
       enddo
C$OMP END PARALLEL DO

       radexp = 0

c
cc      memory management code for constructing level restricted tree
        iert = 0

        call mklraptreemem(iert,source,nsource,radsrc,targ,ntarg,
     1        expc,nexpc,radexp,idivflag,ndiv,isep,nlmax,nbmax,
     2        nlevels,nboxes,mnbors,mnlist1,mnlist2,mnlist3,
     3        mnlist4,mhung,ltree)

        if(ifprint.ge.1) print *, ltree/1.0d9
        if(ifprint.ge.1) print *, "mnlist3 = ",mnlist3
        if(ifprint.ge.1) print *, "mnlist4 = ",mnlist4

        if(iert.ne.0) then
           print *, "Error in allocating tree memory"
           stop
        endif

        allocate(itree(ltree))
        allocate(boxsize(0:nlevels))
        allocate(treecenters(3,nboxes))

c       Call tree code
        call mklraptree(source,nsource,radsrc,targ,ntarg,expc,
     1               nexpc,radexp,idivflag,ndiv,isep,mhung,mnbors,
     2               mnlist1,mnlist2,mnlist3,mnlist4,nlevels,
     2               nboxes,treecenters,boxsize,itree,ltree,ipointer)
      b0 = boxsize(0)
      b0inv = 1.0d0/b0
      b0inv2 = b0inv**2

c     Allocate sorted source and target arrays

      allocate(sourcesort(3,nsource))
      allocate(targsort(3,ntarg))
      if(ifcharge.eq.1) allocate(chargesort(nd,nsource))
      if(ifdipole.eq.1) then
         allocate(dipvecsort(nd,3,nsource))
      endif

      if(ifpgh.eq.1) then
        allocate(potsort(nd,nsource),gradsort(nd,3,1),hesssort(nd,6,1))
      else if(ifpgh.eq.2) then
        allocate(potsort(nd,nsource),gradsort(nd,3,nsource),
     1       hesssort(nd,6,1))
      else if(ifpgh.eq.3) then
        allocate(potsort(nd,nsource),gradsort(nd,3,nsource),
     1       hesssort(nd,6,nsource))
      else
        allocate(potsort(nd,1),gradsort(nd,3,1),hesssort(nd,6,1))
      endif

      if(ifpghtarg.eq.1) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,1),
     1      hesstargsort(nd,6,1))
      else if(ifpghtarg.eq.2) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,ntarg),
     1        hesstargsort(nd,6,1))
      else if(ifpghtarg.eq.3) then
        allocate(pottargsort(nd,ntarg),gradtargsort(nd,3,ntarg),
     1        hesstargsort(nd,6,ntarg))
      else
        allocate(pottargsort(nd,1),gradtargsort(nd,3,1),
     1     hesstargsort(nd,6,1))
      endif

      allocate(nterms(0:nlevels))
c
cc      initialize potential and gradient at source
c       locations
c
      if(ifpgh.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpgh.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)

        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
            gradsort(idim,3,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpgh.eq.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,nsource
          do idim=1,nd
            potsort(idim,i) = 0
            gradsort(idim,1,i) = 0
            gradsort(idim,2,i) = 0
            gradsort(idim,3,i) = 0
            hesssort(idim,1,i) = 0
            hesssort(idim,2,i) = 0
            hesssort(idim,3,i) = 0
            hesssort(idim,4,i) = 0
            hesssort(idim,5,i) = 0
            hesssort(idim,6,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

c
cc       initialize potential and gradient  at targ
c        locations
c
      if(ifpghtarg.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpghtarg.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
            gradtargsort(idim,3,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

      if(ifpghtarg.eq.3) then
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,idim)
        do i=1,ntarg
          do idim=1,nd
            pottargsort(idim,i) = 0
            gradtargsort(idim,1,i) = 0
            gradtargsort(idim,2,i) = 0
            gradtargsort(idim,3,i) = 0
            hesstargsort(idim,1,i) = 0
            hesstargsort(idim,2,i) = 0
            hesstargsort(idim,3,i) = 0
            hesstargsort(idim,4,i) = 0
            hesstargsort(idim,5,i) = 0
            hesstargsort(idim,6,i) = 0
          enddo
        enddo
C$OMP END PARALLEL DO
      endif

c
cc       reorder sources
c
      call dreorderf(3,nsource,source,sourcesort,itree(ipointer(5)))
      call drescale(3*nsource,sourcesort,b0inv)
      if(ifcharge.eq.1) then
        call dreorderf(2*nd,nsource,charge,chargesort,
     1                     itree(ipointer(5)))
        call drescale(2*nd*nsource,chargesort,b0inv)
      endif

      if(ifdipole.eq.1) then
         call dreorderf(6*nd,nsource,dipvec,dipvecsort,
     1       itree(ipointer(5)))
         call drescale(6*nd*nsource,dipvecsort,b0inv2)
      endif

c
cc      reorder targs
c
      call dreorderf(3,ntarg,targ,targsort,itree(ipointer(6)))
      call drescale(3*ntarg,targsort,b0inv)
c
c  update tree centers and boxsize
c
      call drescale(3*nboxes,treecenters,b0inv)
      call drescale(nlevels+1,boxsize,b0inv)

      zkfmm = zk*b0

c
c     scaling factor for multipole and local expansions at all levels
c
      allocate(scales(0:nlevels))
      do ilev = 0,nlevels
       scales(ilev) = boxsize(ilev)*abs(zkfmm)
       if(scales(ilev).gt.1) scales(ilev) = 1
      enddo

c     Compute length of expansions at each level
      nmax = 0
      if(ifprint.ge.1) call prin2('boxsize=*',boxsize,nlevels+1)
      if(ifprint.ge.1) call prin2('zkfmm=*',zkfmm,2)
      do i=0,nlevels
         call h3dterms(boxsize(i),zkfmm,eps,nterms(i))
         if(nterms(i).gt.nmax) nmax = nterms(i)
      enddo
      if(ifprint.ge.1) call prinf('nlevels=*',nlevels,1)
      if(ifprint.ge.1) call prinf('nterms=*',nterms,nlevels+1)
c
c     Multipole and local expansions will be held in workspace
c     in locations pointed to by array iaddr(2,nboxes).
c
c     iiaddr is pointer to iaddr array, itself contained in workspace.
c     imptemp is pointer for single expansion (dimensioned by nmax)
c
c       ... allocate iaddr and temporary arrays
c

      allocate(iaddr(2,nboxes))
      lmptemp = (nmax+1)*(2*nmax+1)*2*nd
      allocate(mptemp(lmptemp),mptemp2(lmptemp))

c
c     allocate memory need by multipole, local expansions at all
c     levels
c     irmlexp is pointer for workspace need by various fmm routines,
c
      call mpalloc(nd,itree(ipointer(1)),iaddr,nlevels,lmptot,nterms)
      if(ifprint.ge. 1) print *, "lmptot =",lmptot/1.0d9

      allocate(rmlexp(lmptot),stat=iert)
      if(iert.ne.0) then
         print *, "Cannot allocate mpole expansion workspace"
         print *, "lmptot=", lmptot
         stop
      endif

c     Memory allocation is complete.
c     Call main fmm routine
c
      call cpu_time(time1)
C$    time1=omp_get_wtime()
      call hfmm3dmain(nd,eps,zkfmm,
     $   nsource,sourcesort,
     $   ifcharge,chargesort,
     $   ifdipole,dipvecsort,
     $   ntarg,targsort,nexpc,expcsort,radssort,
     $   iaddr,rmlexp,lmptot,mptemp,mptemp2,lmptemp,
     $   itree,ltree,ipointer,isep,ndiv,nlevels,
     $   nboxes,boxsize,mnbors,mnlist1,mnlist2,mnlist3,mnlist4,
     $   scales,treecenters,itree(ipointer(1)),nterms,
     $   ifpgh,potsort,gradsort,hesssort,ifpghtarg,pottargsort,
     $   gradtargsort,hesstargsort,ntj,texpssort,scjsort,ifnear)

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      if( ifprint .eq. 1 ) call prin2('time in fmm main=*',
     1   time2-time1,1)

      if(ifpgh.ge.1) then
        call dreorderi(2*nd,nsource,potsort,pot,
     1                 itree(ipointer(5)))
      endif
      if(ifpgh.ge.2) then
        call dreorderi(6*nd,nsource,gradsort,grad,
     1                 itree(ipointer(5)))
        call drescale(6*nd*nsource,grad,b0inv)
      endif

      if(ifpgh.ge.3) then
        call dreorderi(12*nd,nsource,hesssort,hess,
     1                 itree(ipointer(5)))
        call drescale(12*nd*nsource,hess,b0inv2)
      endif

      if(ifpghtarg.ge.1) then
        call dreorderi(2*nd,ntarg,pottargsort,pottarg,
     1     itree(ipointer(6)))
      endif

      if(ifpghtarg.ge.2) then
        call dreorderi(6*nd,ntarg,gradtargsort,gradtarg,
     1     itree(ipointer(6)))
        call drescale(6*nd*ntarg,gradtarg,b0inv)
      endif

      if(ifpghtarg.ge.3) then
        call dreorderi(12*nd,ntarg,hesstargsort,hesstarg,
     1     itree(ipointer(6)))
        call drescale(12*nd*ntarg,hesstarg,b0inv2)
      endif

      return
      end
c
c
      subroutine hfmm3dmain(nd,eps,zk,
     $     nsource,sourcesort,
     $     ifcharge,chargesort,
     $     ifdipole,dipvecsort,
     $     ntarg,targsort,nexpc,expcsort,radssort,
     $     iaddr,rmlexp,lmptot,mptemp,mptemp2,lmptemp,
     $     itree,ltree,ipointer,isep,ndiv,nlevels,
     $     nboxes,boxsize,mnbors,mnlist1,mnlist2,mnlist3,mnlist4,
     $     rscales,centers,laddr,nterms,ifpgh,pot,grad,hess,
     $     ifpghtarg,pottarg,gradtarg,hesstarg,
     $     ntj,jsort,scjsort,ifnear)
      implicit none

      integer nd
      double precision eps
      integer nsource,ntarg, nexpc
      integer ndiv,nlevels

      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      double complex zk,zk2

      double precision sourcesort(3,nsource)

      double complex chargesort(nd,*)
      double complex dipvecsort(nd,3,*)

      double precision targsort(3,ntarg)

      double complex pot(nd,*),grad(nd,3,*),hess(nd,6,*)
      double complex pottarg(nd,*),gradtarg(nd,3,*),hesstarg(nd,6,*)

      integer ntj
      integer ifnear
      double precision expcsort(3,nexpc)
      double complex jsort(nd,0:ntj,-ntj:ntj,nexpc)

      integer lmptemp
      integer *8 iaddr(2,nboxes), lmptot
      double precision rmlexp(lmptot)
      double precision mptemp(lmptemp)
      double precision mptemp2(lmptemp)

      double precision timeinfo(10)
      double precision centers(3,nboxes)
c
cc      tree variables
c
      integer isep
      integer *8 ltree
      integer laddr(2,0:nlevels)
      integer nterms(0:nlevels)
      integer *8 ipointer(32)
      integer itree(ltree)
      integer nboxes
      double precision rscales(0:nlevels)
      double precision boxsize(0:nlevels)
c
cc      pw stuff
c
      integer nuall,ndall,nnall,nsall,neall,nwall
      integer nu1234,nd5678,nn1256,ns3478,ne1357,nw2468
      integer nn12,nn56,ns34,ns78,ne13,ne57,nw24,nw68
      integer ne1,ne3,ne5,ne7,nw2,nw4,nw6,nw8

      integer uall(200),dall(200),nall(120),sall(120),eall(72),wall(72)
      integer u1234(36),d5678(36),n1256(24),s3478(24)
      integer e1357(16),w2468(16),n12(20),n56(20),s34(20),s78(20)
      integer e13(20),e57(20),w24(20),w68(20)
      integer e1(20),e3(5),e5(5),e7(5),w2(5),w4(5),w6(5),w8(5)

      integer ntmax, nexpmax, nlams, nmax, nthmax, nphmax
      double precision, allocatable :: carray(:,:), dc(:,:)
      double precision, allocatable :: rdplus(:,:,:)
      double precision, allocatable :: rdminus(:,:,:), rdsq3(:,:,:)
      double precision, allocatable :: rdmsq3(:,:,:)
      double complex, allocatable :: rdminus2(:,:,:),zeyep(:)
      double complex, allocatable :: rdplus2(:,:,:)
      double precision, allocatable :: zmone(:)
      integer nn,nnn

      double complex, allocatable :: rlams(:),whts(:)

      double complex, allocatable :: rlsc(:,:,:)
      integer, allocatable :: nfourier(:), nphysical(:)
      integer nexptot, nexptotp
      double complex, allocatable :: xshift(:,:),yshift(:,:),zshift(:,:)

      double complex, allocatable :: fexp(:),fexpback(:)

      double complex, allocatable :: mexp(:,:,:,:)
      double complex, allocatable :: tmp(:,:,:),tmp2(:,:,:)
      double complex, allocatable :: mexpf1(:,:),mexpf2(:,:)
      double complex, allocatable :: mexpp1(:,:),mexpp2(:,:),
     1    mexppall(:,:,:)

      double precision, allocatable :: rsc(:)
      double precision r1

      double precision scjsort(nexpc),radssort(nexpc)

c     temp variables
      integer i,j,k,l,ii,jj,kk,ll,idim
      integer ibox,jbox,ilev,npts,npts0
      integer nchild,nlist1,nlist2,nlist3,nlist4

      integer istart,iend,istartt,iendt,istarte,iende
      integer istarts,iends
      integer jstart,jend

      integer ifprint,ifwrite

      integer ifhesstarg
      double precision d,time1,time2,omp_get_wtime

      double precision sourcetmp(3)
      double complex chargetmp(nd)

      integer ix,iy,iz
      double precision rtmp
      double complex zmul

      integer nlege, lw7, lused7, itype
      double precision, allocatable :: wlege(:)

      double precision thresh

      integer mnbors,mnlist1, mnlist2,mnlist3,mnlist4
      double complex eye, ztmp,zmult
      double precision alphaj
      integer ctr,ifinit2
      double precision, allocatable :: xnodes(:),wts(:)
      double precision radius
      integer nquad2
      integer maX_nodes
      double precision pi

      integer istart0,istart1,istartm1,nprin
      double precision rtmp1,rtmp2,rtmp3,rtmp4
      double precision ctmp(3)
      double complex ima

c     list 3 variables
      double complex, allocatable :: iboxlexp(:,:)
      double precision iboxsubcenters(3,8)
      double complex, allocatable :: iboxpot(:,:)
      double complex, allocatable :: iboxgrad(:,:,:)
      double precision, allocatable :: iboxsrc(:,:)
      integer, allocatable :: iboxsrcind(:)
      integer iboxfl(2,8)
c     end of list 3 variables
c     list 4 variables
      integer cntlist4
      integer, allocatable :: list4(:),ilist4(:)
      double complex, allocatable :: pgboxwexp(:,:,:,:)

c     end of list 4 variables

      integer *8 bigint
      double precision zkiupbound,zi,zkrupbound,rz
      integer ilevcutoff

      integer iert
      data ima/(0.0d0,1.0d0)/

      integer nlfbox,ier

      ntmax = 1000
      allocate(nfourier(ntmax),nphysical(ntmax))
      allocate(rlams(ntmax),whts(ntmax))

      pi = 4.0d0*atan(1.0d0)
c     ifprint is an internal information printing flag.
c     Suppressed if ifprint=0.
c     Prints timing breakdown and other things if ifprint=1.
c     Prints timing breakdown, list information, and other things if ifprint=2.
c
        ifprint=0

c
c      If imaginary part is greater than 12*pi
c    don't do any multipole/local work
c

      zkiupbound = 12*pi
      zkrupbound = 16*pi
      zi = imag(zk)

      ilevcutoff = -1

      nmax = 0
      do i=0,nlevels
         if(nmax.lt.nterms(i)) nmax = nterms(i)
         rz = exp(-zi*boxsize(i))/boxsize(i)
         if(rz.lt.eps) ilevcutoff = i
      enddo

      if(ifprint.ge.1) print *, "ilevcutoff=",ilevcutoff

      allocate(rsc(0:nmax))

c
cc     threshold for computing interactions,
c      interactions will be ignored
c      for all pairs of sources and targets
c      which satisfy |r| < thresh
c      where r is the disance between them

      thresh = 2.0d0**(-51)*boxsize(0)

      if(ifprint.ge.1) print *, "thresh=",thresh

      allocate(zeyep(-nmax:nmax),zmone(0:2*nmax))

      zeyep(0) = 1
      zmult = -ima
      do i=1,nmax
         zeyep(i) = zeyep(i-1)*zmult
         zeyep(-i) = zeyep(-i+1)/zmult
      enddo

      zmone(0) = 1
      do i=1,2*nmax
         zmone(i) = -zmone(i-1)
      enddo

c
c
c     ... set the expansion coefficients to zero
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k,idim)
      do i=1,nexpc
         do k=-ntj,ntj
           do j = 0,ntj
              do idim=1,nd
                jsort(idim,j,k,i)=0
              enddo
           enddo
         enddo
      enddo
C$OMP END PARALLEL DO

c
      do i=1,10
        timeinfo(i)=0
      enddo

      max_nodes = 10000
      allocate(xnodes(max_nodes))
      allocate(wts(max_nodes))

c
c       ... set all multipole and local expansions to zero
c
      do ilev = 0,nlevels
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox)
         do ibox = laddr(1,ilev),laddr(2,ilev)
            call mpzero(nd,rmlexp(iaddr(1,ibox)),nterms(ilev))
            call mpzero(nd,rmlexp(iaddr(2,ibox)),nterms(ilev))
         enddo
C$OMP END PARALLEL DO
       enddo

c
ccc       set scjsort
c
      do ilev=0,nlevels
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,i)
         do ibox=laddr(1,ilev),laddr(2,ilev)
            nchild = itree(ipointer(3)+ibox-1)
            if(nchild.gt.0) then
               istart = itree(ipointer(16)+ibox-1)
               iend = itree(ipointer(17)+ibox-1)
               do i=istart,iend
                  scjsort(i) = rscales(ilev)
                  radssort(i) = min(radssort(i),boxsize(ilev)/32*
     1                            sqrt(3.0d0))
               enddo
            endif
         enddo
C$OMP END PARALLEL DO
      enddo

c    initialize legendre function evaluation routines
      nlege = nmax + 10
      lw7 = (nlege+1)**2*4
      allocate(wlege(lw7))
      call ylgndrfwini(nlege,wlege,lw7,lused7)

      allocate(list4(nboxes))
      allocate(ilist4(nboxes))
      do i=1,nboxes
        list4(i)=0
        ilist4(i)=0
      enddo
      cntlist4=0

c
c
      if(ifprint .ge. 1)
     $   call prinf('=== STEP 1 (form mp) ====*',i,0)
        call cpu_time(time1)
C$        time1=omp_get_wtime()
c
c       ... step 1, locate all charges, assign them to boxes, and
c       form multipole expansions

      do ilev=2,nlevels
        if(ilev.gt.ilevcutoff) then
          if(ifcharge.eq.1.and.ifdipole.eq.0) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,npts,istart,iend,nchild)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = iend-istart+1

              nchild = itree(ipointer(3)+ibox-1)

              if(npts.gt.0.and.nchild.eq.0) then
                call h3dformmpc(nd,zk,rscales(ilev),
     1          sourcesort(1,istart),chargesort(1,istart),npts,
     2          centers(1,ibox),nterms(ilev),
     3          rmlexp(iaddr(1,ibox)),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.0.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,npts,istart,iend,nchild)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = iend-istart+1

              nchild = itree(ipointer(3)+ibox-1)

              if(npts.gt.0.and.nchild.eq.0) then
                call h3dformmpd(nd,zk,rscales(ilev),
     1          sourcesort(1,istart),
     2          dipvecsort(1,1,istart),npts,
     2          centers(1,ibox),nterms(ilev),
     3          rmlexp(iaddr(1,ibox)),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifdipole.eq.1.and.ifcharge.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,npts,istart,iend,nchild)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = iend-istart+1

              nchild = itree(ipointer(3)+ibox-1)

              if(npts.gt.0.and.nchild.eq.0) then
                call h3dformmpcd(nd,zk,rscales(ilev),
     1          sourcesort(1,istart),chargesort(1,istart),
     2          dipvecsort(1,1,istart),npts,
     2          centers(1,ibox),nterms(ilev),
     3          rmlexp(iaddr(1,ibox)),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif
        endif
      enddo

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(1)=time2-time1

c
      if(ifprint .ge. 1)
     $      call prinf('=== STEP 2 (merge mp) ====*',i,0)
      call cpu_time(time1)
C$    time1=omp_get_wtime()
c

      do ilev=nlevels-1,1,-1
        if(ilev.gt.ilevcutoff) then
          nquad2 = nterms(ilev)*2.5
          nquad2 = max(6,nquad2)
          ifinit2 = 1
          call legewhts(nquad2,xnodes,wts,ifinit2)
          radius = boxsize(ilev)/2*sqrt(3.0d0)

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,i,jbox,istart,iend,npts)
          do ibox = laddr(1,ilev),laddr(2,ilev)
            do i=1,8
              jbox = itree(ipointer(4)+8*(ibox-1)+i-1)
              if(jbox.gt.0) then
                istart = itree(ipointer(10)+jbox-1)
                iend = itree(ipointer(11)+jbox-1)
                npts = iend-istart+1

                if(npts.gt.0) then
                  call h3dmpmp(nd,zk,rscales(ilev+1),
     1              centers(1,jbox),rmlexp(iaddr(1,jbox)),
     2              nterms(ilev+1),rscales(ilev),centers(1,ibox),
     3              rmlexp(iaddr(1,ibox)),nterms(ilev),
     4              radius,xnodes,wts,nquad2)
                endif
              endif
            enddo
          enddo
C$OMP END PARALLEL DO
        endif
      enddo

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(3)=time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== Step 3 (mp to loc+mpeval+formta) ===*',i,0)
c      ... step 3, convert multipole expansions into local
c       expansions and big to small far and small to far big

      call cpu_time(time1)
C$    time1=omp_get_wtime()
      do ilev = 2,nlevels
        zk2 = zk*boxsize(ilev)
        if(real(zk2).le.zkrupbound.and.imag(zk2).lt.zkiupbound.and.
     1        ilev.gt.ilevcutoff) then
c             get new pw quadrature

          ier = 0
          call hwts3e(ier,eps,zk2,rlams,whts,nlams)
          call hnumfour(eps,zk2,nlams,nfourier)
          call hnumphys(eps,zk2,nlams,nphysical)

          nphmax = 0
          nthmax = 0
          nexptotp = 0
          nexptot = 0
          nn = 0
          do i=1,nlams
            nexptotp = nexptotp + nphysical(i)
            nexptot = nexptot + 2*nfourier(i)+1
            nn = nn + nfourier(i)*nphysical(i)
            if(nfourier(i).gt.nthmax) nthmax = nfourier(i)
            if(nphysical(i).gt.nphmax) nphmax = nphysical(i)
          enddo
          allocate(fexp(nn),fexpback(nn))

          allocate(xshift(-5:5,nexptotp))
          allocate(yshift(-5:5,nexptotp))
          allocate(zshift(5,nexptotp))
          allocate(rlsc(0:nterms(ilev),0:nterms(ilev),nlams))
          allocate(tmp(nd,0:nterms(ilev),-nterms(ilev):nterms(ilev)))
          allocate(tmp2(nd,0:nterms(ilev),-nterms(ilev):nterms(ilev)))

          allocate(mexpf1(nd,nexptot),mexpf2(nd,nexptot),
     1          mexpp1(nd,nexptotp))
          allocate(mexpp2(nd,nexptotp),mexppall(nd,nexptotp,16))

          bigint = 0
          bigint = nboxes
          bigint = bigint*6
          bigint = bigint*nexptotp*nd

          if(ifprint.ge.1) print *, "mexp memory=",bigint/1.0d9

          allocate(mexp(nd,nexptotp,nboxes,6),stat=iert)
          if(iert.ne.0) then
            print *, "Cannot allocate pw expansion workspace"
            print *, "bigint=", bigint
            stop
          endif

          nn = nterms(ilev)
          allocate(carray(4*nn+1,4*nn+1))
          allocate(dc(0:4*nn,0:4*nn))
          allocate(rdplus(0:nn,0:nn,-nn:nn))
          allocate(rdminus(0:nn,0:nn,-nn:nn))
          allocate(rdsq3(0:nn,0:nn,-nn:nn))
          allocate(rdmsq3(0:nn,0:nn,-nn:nn))

c     generate rotation matrices and carray
          call getpwrotmat(nn,carray,rdplus,rdminus,rdsq3,rdmsq3,dc)

          call hrlscini(rlsc,nlams,rlams,rscales(ilev),zk2,
     1         nterms(ilev))
          call hmkexps(rlams,nlams,nphysical,nexptotp,zk2,xshift,
     1           yshift,zshift)
          call hmkfexp(nlams,nfourier,nphysical,fexp,fexpback)

c
cc      zero out mexp
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(idim,i,j,k)
          do k=1,6
            do i=1,nboxes
              do j=1,nexptotp
                do idim=1,nd
                  mexp(idim,j,i,k) = 0.0d0
                enddo
              enddo
            enddo
          enddo
C$OMP END PARALLEL DO

c
c         note: the scaling for helmholtz has been eliminated
c         since it is taken care in the scaling of the legendre
c         functions
c
          r1 = 1.0d0
          rsc(0) = 1.0d0
          do i=1,nterms(ilev)
            rsc(i) = rsc(i-1)*r1
          enddo

c      generate ilev+1 list4 type box plane wave expansion
          cntlist4=0
          do ibox=laddr(1,ilev-1),laddr(2,ilev-1)
            nlist3=itree(ipointer(24)+ibox-1)
            if(nlist3.gt.0) then
              cntlist4=cntlist4+1
              list4(ibox)=cntlist4
            endif
          enddo
          allocate(pgboxwexp(nd,nexptotp,cntlist4,6))
          if(ifprint.ge.1) print *,"cntlist4:",cntlist4,"ilev:",ilev

          call h3dlist4pw(ilev-1,zk,nd,nexptotp,nexptot,nterms(ilev),
     1       nn,nlams,nlege,nlevels,ifcharge,ifdipole,list4,itree,
     2       laddr,ipointer,nfourier,nphysical,
     3       rdminus,rdplus,rlsc,
     4       rscales(ilev),boxsize(ilev),xshift,yshift,zshift,
     5       sourcesort,chargesort,dipvecsort,centers,fexp,
     6       mexpf1,mexpf2,tmp,tmp2,wlege,rlams,rsc,pgboxwexp,
     7       cntlist4)

c
cc         create multipole to plane wave expansion for
c          all boxes at this level
c
C$OMP PARALLEL DO DEFAULT (SHARED)
C$OMP$PRIVATE(ibox,istart,iend,npts,tmp,mexpf1,mexpf2,tmp2)
          do ibox = laddr(1,ilev),laddr(2,ilev)
            istart = itree(ipointer(10)+ibox-1)
            iend = itree(ipointer(11)+ibox-1)
            npts = iend - istart+1
            if(npts.gt.0) then

c           rescale multipole expansion
              call mpscale(nd,nterms(ilev),rmlexp(iaddr(1,ibox)),
     1               rsc,tmp)

              call hmpoletoexp(nd,tmp,nterms(ilev),
     1          nlams,nfourier,nexptot,mexpf1,mexpf2,rlsc)

              call hftophys(nd,mexpf1,nlams,nfourier,nphysical,
     1                 mexp(1,1,ibox,1),fexp)

              call hftophys(nd,mexpf2,nlams,nfourier,nphysical,
     1                 mexp(1,1,ibox,2),fexp)

c          form mexpnorth, mexpsouth for current box

c          Rotate mpole for computing mexpnorth and
c          mexpsouth
              call rotztoy(nd,nterms(ilev),tmp,
     1                           tmp2,rdminus)

              call hmpoletoexp(nd,tmp2,nterms(ilev),nlams,
     1                  nfourier,nexptot,mexpf1,mexpf2,rlsc)

              call hftophys(nd,mexpf1,nlams,nfourier,
     1                 nphysical,mexp(1,1,ibox,3),fexp)

              call hftophys(nd,mexpf2,nlams,nfourier,
     1                 nphysical,mexp(1,1,ibox,4),fexp)

c         Rotate mpole for computing mexpeast, mexpwest
              call rotztox(nd,nterms(ilev),tmp,
     1                              tmp2,rdplus)
              call hmpoletoexp(nd,tmp2,nterms(ilev),nlams,
     1                  nfourier,nexptot,mexpf1,mexpf2,rlsc)

              call hftophys(nd,mexpf1,nlams,nfourier,
     1                 nphysical,mexp(1,1,ibox,5),fexp)

              call hftophys(nd,mexpf2,nlams,nfourier,
     1                 nphysical,mexp(1,1,ibox,6),fexp)

            endif
          enddo
C$OMP END PARALLEL DO

c
cc         loop over parent boxes and ship plane wave
c          expansions to the first child of parent
c          boxes.
c          The codes are now written from a gathering perspective
c
c          so the first child of the parent is the one
c          recieving all the local expansions
c          coming from all the lists
c
c
c

C$OMP PARALLEL DO DEFAULT (SHARED)
C$OMP$PRIVATE(ibox,istart,iend,npts,nchild)
C$OMP$PRIVATE(mexpf1,mexpf2,mexpp1,mexpp2,mexppall)
C$OMP$PRIVATE(nuall,uall,ndall,dall,nnall,nall,nsall,sall)
C$OMP$PRIVATE(neall,eall,nwall,wall,nu1234,u1234,nd5678,d5678)
C$OMP$PRIVATE(nn1256,n1256,ns3478,s3478,ne1357,e1357,nw2468,w2468)
C$OMP$PRIVATE(nn12,n12,nn56,n56,ns34,s34,ns78,s78,ne13,e13,ne57,e57)
C$OMP$PRIVATE(nw24,w24,nw68,w68,ne1,e1,ne3,e3,ne5,e5,ne7,e7)
C$OMP$PRIVATE(nw2,w2,nw4,w4,nw6,w6,nw8,w8)
C$OMP$PRIVATE(npts0,nlist3,ctmp,jstart,jend,i,iboxfl,iboxsubcenters)
C$OMP$PRIVATE(iboxpot,iboxgrad,iboxlexp,iboxsrc,iboxsrcind)
          do ibox = laddr(1,ilev-1),laddr(2,ilev-1)
            npts = 0
            if(ifpghtarg.gt.0) then
              istart = itree(ipointer(12)+ibox-1)
              iend = itree(ipointer(13)+ibox-1)
              npts = npts + iend-istart+1
            endif

            istart = itree(ipointer(14)+ibox-1)
            iend = itree(ipointer(17)+ibox-1)
            npts = npts + iend-istart+1

            nchild = itree(ipointer(3)+ibox-1)

            if(ifpgh.gt.0) then
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = npts + iend-istart+1
            endif

            if(npts.gt.0.and.nchild.gt.0) then
              call getpwlistall(ibox,boxsize(ilev),nboxes,
     1           itree(ipointer(18)+ibox-1),itree(ipointer(19)+
     2           mnbors*(ibox-1)),nchild,itree(ipointer(4)),centers,
     3           isep,nuall,uall,ndall,dall,nnall,nall,nsall,sall,
     4           neall,eall,nwall,wall,nu1234,u1234,nd5678,d5678,
     5           nn1256,n1256,ns3478,s3478,ne1357,e1357,nw2468,w2468,
     6           nn12,n12,nn56,n56,ns34,s34,ns78,s78,ne13,e13,ne57,
     7           e57,nw24,w24,nw68,w68,ne1,e1,ne3,e3,ne5,e5,ne7,e7,
     8           nw2,w2,nw4,w4,nw6,w6,nw8,w8)

              call hprocessudexp(nd,zk2,ibox,ilev,nboxes,centers,
     1            itree(ipointer(4)),rscales(ilev),boxsize(ilev),
     2            nterms(ilev),iaddr,rmlexp,rlams,whts,
     3            nlams,nfourier,nphysical,nthmax,nexptot,nexptotp,mexp,
     4            nuall,uall,nu1234,u1234,ndall,dall,nd5678,d5678,
     5            mexpf1,mexpf2,mexpp1,mexpp2,mexppall(1,1,1),
     6            mexppall(1,1,2),mexppall(1,1,3),mexppall(1,1,4),
     7            xshift,yshift,zshift,fexpback,rlsc,
     8            pgboxwexp,cntlist4,list4,
     9            itree(ipointer(26)),itree(ipointer(27)),mnlist4)

              call hprocessnsexp(nd,zk2,ibox,ilev,nboxes,centers,
     1            itree(ipointer(4)),rscales(ilev),boxsize(ilev),
     2            nterms(ilev),iaddr,rmlexp,rlams,whts,
     3            nlams,nfourier,nphysical,nthmax,nexptot,nexptotp,mexp,
     4            nnall,nall,nn1256,n1256,nn12,n12,nn56,n56,nsall,sall,
     5            ns3478,s3478,ns34,s34,ns78,s78,
     6            mexpf1,mexpf2,mexpp1,mexpp2,mexppall(1,1,1),
     7            mexppall(1,1,2),mexppall(1,1,3),mexppall(1,1,4),
     8            mexppall(1,1,5),mexppall(1,1,6),mexppall(1,1,7),
     9            mexppall(1,1,8),rdplus,xshift,yshift,zshift,
     9            fexpback,rlsc,
     9            pgboxwexp,cntlist4,list4,
     9            itree(ipointer(26)),itree(ipointer(27)),mnlist4)

              call hprocessewexp(nd,zk2,ibox,ilev,nboxes,centers,
     1            itree(ipointer(4)),rscales(ilev),boxsize(ilev),
     2            nterms(ilev),iaddr,rmlexp,rlams,whts,
     3            nlams,nfourier,nphysical,nthmax,nexptot,nexptotp,mexp,
     4            neall,eall,ne1357,e1357,ne13,e13,ne57,e57,ne1,e1,
     5            ne3,e3,ne5,e5,ne7,e7,nwall,wall,
     5            nw2468,w2468,nw24,w24,nw68,w68,
     5            nw2,w2,nw4,w4,nw6,w6,nw8,w8,
     6            mexpf1,mexpf2,mexpp1,mexpp2,mexppall(1,1,1),
     7            mexppall(1,1,2),mexppall(1,1,3),mexppall(1,1,4),
     8            mexppall(1,1,5),mexppall(1,1,6),
     8            mexppall(1,1,7),mexppall(1,1,8),mexppall(1,1,9),
     9            mexppall(1,1,10),mexppall(1,1,11),mexppall(1,1,12),
     9            mexppall(1,1,13),mexppall(1,1,14),mexppall(1,1,15),
     9            mexppall(1,1,16),rdminus,xshift,yshift,zshift,
     9            fexpback,rlsc,pgboxwexp,cntlist4,list4,
     9            itree(ipointer(26)),itree(ipointer(27)),mnlist4)
            endif

c
c      handle mp eval
c

            nlist3 = itree(ipointer(24)+ibox-1)
            if(nlist3.gt.0.and.npts.gt.0) then
              call getlist3pwlistall(ibox,boxsize(ilev),nboxes,
     1              nlist3,itree(ipointer(25)+(ibox-1)*mnlist3),isep,
     2              centers,nuall,uall,ndall,dall,nnall,nall,
     3              nsall,sall,neall,eall,nwall,wall)

              allocate(iboxlexp(nd*(nterms(ilev)+1)*
     1                   (2*nterms(ilev)+1),8))

c
c              note: iboxlexp is a matrix
c
              iboxlexp=0

              call hprocesslist3udexplong(nd,zk2,ibox,nboxes,centers,
     1               boxsize(ilev),nterms(ilev),iboxlexp,rlams,whts,
     2               nlams,nfourier,nphysical,nthmax,nexptot,
     3               nexptotp,mexp,nuall,uall,ndall,dall,
     4               mexpf1,mexpf2,mexpp1,mexpp2,
     5               mexppall(1,1,1),mexppall(1,1,2),
     6               xshift,yshift,zshift,fexpback,rlsc)

              call hprocesslist3nsexplong(nd,zk2,ibox,nboxes,centers,
     1           boxsize(ilev),nterms(ilev),iboxlexp,rlams,whts,
     2           nlams,nfourier,nphysical,nthmax,nexptot,
     3           nexptotp,mexp,nnall,nall,nsall,sall,
     4           mexpf1,mexpf2,mexpp1,mexpp2,
     5           mexppall(1,1,1),mexppall(1,1,2),rdplus,
     6           xshift,yshift,zshift,fexpback,rlsc)

              call hprocesslist3ewexplong(nd,zk2,ibox,nboxes,centers,
     1              boxsize(ilev),nterms(ilev),iboxlexp,rlams,whts,
     2              nlams,nfourier,nphysical,nthmax,nexptot,
     3              nexptotp,mexp,neall,eall,nwall,wall,
     4              mexpf1,mexpf2,mexpp1,mexpp2,
     5              mexppall(1,1,1),mexppall(1,1,2),rdminus,
     6              xshift,yshift,zshift,fexpback,rlsc)

              if(ifpgh.eq.1) then
                istart = itree(ipointer(10)+ibox-1)
                iend = itree(ipointer(11)+ibox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  allocate(iboxsrcind(npts))
                  allocate(iboxsrc(3,npts))
                  allocate(iboxpot(nd,npts))
                  call subdividebox(sourcesort(1,istart),npts,
     1                    centers(1,ibox),boxsize(ilev),
     2                    iboxsrcind,iboxfl,iboxsubcenters)
                  call dreorderf(3,npts,sourcesort(1,istart),
     1                    iboxsrc,iboxsrcind)
                  call dreorderf(2*nd,npts,pot(1,istart),
     1                    iboxpot,iboxsrcind)
                  do i=1,8
                    if(iboxfl(1,i).gt.0) then
                      jstart=iboxfl(1,i)
                      jend=iboxfl(2,i)
                      npts0=jend-jstart+1
                      if(npts0.gt.0) then
                        call h3dtaevalp(nd,zk,rscales(ilev),
     1                    iboxsubcenters(1,i),iboxlexp(1,i),
     2                    nterms(ilev),iboxsrc(1,jstart),npts0,
     3                    iboxpot(1,jstart),wlege,nlege)
                      endif
                    endif
                  enddo
                  call dreorderi(2*nd,npts,iboxpot,pot(1,istart),
     1                    iboxsrcind)
                  deallocate(iboxsrcind,iboxsrc)
                  deallocate(iboxpot)
                endif
              endif

              if(ifpgh.eq.2) then
                istart = itree(ipointer(10)+ibox-1)
                iend = itree(ipointer(11)+ibox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  allocate(iboxsrcind(npts))
                  allocate(iboxsrc(3,npts))
                  allocate(iboxpot(nd,npts))
                  allocate(iboxgrad(nd,3,npts))
                  call subdividebox(sourcesort(1,istart),npts,
     1                  centers(1,ibox),boxsize(ilev),
     2                  iboxsrcind,iboxfl,iboxsubcenters)
                  call dreorderf(3,npts,sourcesort(1,istart),
     1                   iboxsrc,iboxsrcind)
                  call dreorderf(2*nd,npts,pot(1,istart),
     1                   iboxpot,iboxsrcind)
                  call dreorderf(6*nd,npts,grad(1,1,istart),
     1                   iboxgrad,iboxsrcind)
                  do i=1,8
                    if(iboxfl(1,i).gt.0) then
                      jstart=iboxfl(1,i)
                      jend=iboxfl(2,i)
                      npts0=jend-jstart+1
                      if(npts0.gt.0) then
                        call h3dtaevalg(nd,zk,rscales(ilev),
     1                        iboxsubcenters(1,i),iboxlexp(1,i),
     2                        nterms(ilev),iboxsrc(1,jstart),npts0,
     3                        iboxpot(1,jstart),iboxgrad(1,1,jstart),
     4                        wlege,nlege)
                      endif
                    endif
                  enddo
                  call dreorderi(2*nd,npts,iboxpot,pot(1,istart),
     1                    iboxsrcind)
                  call dreorderi(6*nd,npts,iboxgrad,grad(1,1,istart),
     1                    iboxsrcind)
                  deallocate(iboxsrcind,iboxsrc)
                  deallocate(iboxpot,iboxgrad)
                endif
              endif

              if(ifpghtarg.eq.1) then
                istart = itree(ipointer(12)+ibox-1)
                iend = itree(ipointer(13)+ibox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  allocate(iboxsrcind(npts))
                  allocate(iboxsrc(3,npts))
                  allocate(iboxpot(nd,npts))
                  call subdividebox(targsort(1,istart),npts,
     1                   centers(1,ibox),boxsize(ilev),
     2                   iboxsrcind,iboxfl,iboxsubcenters)
                  call dreorderf(3,npts,targsort(1,istart),
     1                   iboxsrc,iboxsrcind)
                  call dreorderf(2*nd,npts,pottarg(1,istart),
     1                   iboxpot,iboxsrcind)
                  do i=1,8
                    if(iboxfl(1,i).gt.0) then
                      jstart=iboxfl(1,i)
                      jend=iboxfl(2,i)
                      npts0=jend-jstart+1
                      if(npts0.gt.0) then
                        call h3dtaevalp(nd,zk,rscales(ilev),
     1                     iboxsubcenters(1,i),iboxlexp(1,i),
     2                     nterms(ilev),iboxsrc(1,jstart),npts0,
     3                     iboxpot(1,jstart),wlege,nlege)
                      endif
                    endif
                  enddo
                  call dreorderi(2*nd,npts,iboxpot,pottarg(1,istart),
     1                    iboxsrcind)
                  deallocate(iboxsrcind,iboxsrc)
                  deallocate(iboxpot)
                endif
              endif

              if(ifpghtarg.eq.2) then
                istart = itree(ipointer(12)+ibox-1)
                iend = itree(ipointer(13)+ibox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  allocate(iboxsrcind(npts))
                  allocate(iboxsrc(3,npts))
                  allocate(iboxpot(nd,npts))
                  allocate(iboxgrad(nd,3,npts))
                  call subdividebox(targsort(1,istart),npts,
     1                  centers(1,ibox),boxsize(ilev),
     2                  iboxsrcind,iboxfl,iboxsubcenters)
                  call dreorderf(3,npts,targsort(1,istart),
     1                    iboxsrc,iboxsrcind)
                  call dreorderf(2*nd,npts,pottarg(1,istart),
     1                    iboxpot,iboxsrcind)
                  call dreorderf(6*nd,npts,gradtarg(1,1,istart),
     1                    iboxgrad,iboxsrcind)
                  do i=1,8
                    if(iboxfl(1,i).gt.0) then
                      jstart=iboxfl(1,i)
                      jend=iboxfl(2,i)
                      npts0=jend-jstart+1
                      if(npts0.gt.0) then
                        call h3dtaevalg(nd,zk,rscales(ilev),
     1                       iboxsubcenters(1,i),iboxlexp(1,i),
     2                       nterms(ilev),iboxsrc(1,jstart),npts0,
     3                       iboxpot(1,jstart),iboxgrad(1,1,jstart),
     4                       wlege,nlege)
                      endif
                    endif
                  enddo
                  call dreorderi(2*nd,npts,iboxpot,pottarg(1,istart),
     1                    iboxsrcind)
                  call dreorderi(6*nd,npts,iboxgrad,
     1                    gradtarg(1,1,istart),iboxsrcind)
                  deallocate(iboxsrcind,iboxsrc)
                  deallocate(iboxpot,iboxgrad)
                endif
              endif
              deallocate(iboxlexp)
            endif
          enddo
C$OMP END PARALLEL DO

          deallocate(xshift,yshift,zshift,rlsc,tmp,tmp2)
          deallocate(carray,dc,rdplus,rdminus,rdsq3,rdmsq3)

          deallocate(mexpf1,mexpf2,mexpp1,mexpp2,mexppall,mexp)
          deallocate(fexp,fexpback)

          deallocate(pgboxwexp)
        else if((real(zk2).gt.zkrupbound.or.imag(zk2).gt.zkiupbound).
     1            and.ilev.gt.ilevcutoff) then
          nquad2 = nterms(ilev)*2.2
          if(ifprint.ge.1) print *, "In point and shoot regime"
          nquad2 = max(6,nquad2)

          ifinit2 = 1
          ier = 0

          call legewhts(nquad2,xnodes,wts,ifinit2)

          radius = boxsize(ilev)/2*sqrt(3.0d0)
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istart,iend,npts,nlist2,i,jbox)
          do ibox = laddr(1,ilev),laddr(2,ilev)
            npts = 0
            if(ifpghtarg.gt.0) then
              istart = itree(ipointer(12)+ibox-1)
              iend = itree(ipointer(13)+ibox-1)
              npts = npts + iend - istart + 1
            endif

            istart = itree(ipointer(14)+ibox-1)
            iend = itree(ipointer(17)+ibox-1)
            npts = npts + iend-istart+1

            if(ifpgh.gt.0) then
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = npts + iend-istart+1
            endif

            nlist2 = itree(ipointer(22)+ibox-1)
            if(npts.gt.0) then
              do i =1,nlist2
                jbox = itree(ipointer(23)+mnlist2*(ibox-1)+i-1)

                istart = itree(ipointer(10)+jbox-1)
                iend = itree(ipointer(11)+jbox-1)
                npts = iend-istart+1

                if(npts.gt.0) then
                  call h3dmploc(nd,zk,rscales(ilev),centers(1,jbox),
     1                  rmlexp(iaddr(1,jbox)),nterms(ilev),
     2                  rscales(ilev),centers(1,ibox),
     2                  rmlexp(iaddr(2,ibox)),nterms(ilev),
     3                  radius,xnodes,wts,nquad2)
                endif
              enddo
            endif
          enddo
C$OMP END PARALLEL DO

c
c
c         handle list 3 interactions at this level
c

          if(ifpgh.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nlist3,istart,iend,npts,i,jbox)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev-1),laddr(2,ilev-1)
              nlist3 = itree(ipointer(24)+ibox-1)
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)

              npts = iend-istart+1

              do i=1,nlist3
                jbox = itree(ipointer(25)+(ibox-1)*mnlist3+i-1)
                call h3dmpevalp(nd,zk,rscales(ilev),centers(1,jbox),
     1            rmlexp(iaddr(1,jbox)),nterms(ilev),
     2            sourcesort(1,istart),npts,pot(1,istart),wlege,nlege,
     3            thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpgh.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nlist3,istart,iend,npts,i,jbox)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev-1),laddr(2,ilev-1)
              nlist3 = itree(ipointer(24)+ibox-1)
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)

              npts = iend-istart+1

              do i=1,nlist3
                jbox = itree(ipointer(25)+(ibox-1)*mnlist3+i-1)
                call h3dmpevalg(nd,zk,rscales(ilev),centers(1,jbox),
     1             rmlexp(iaddr(1,jbox)),nterms(ilev),
     2             sourcesort(1,istart),npts,pot(1,istart),
     3             grad(1,1,istart),wlege,nlege,thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpghtarg.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nlist3,istart,iend,npts,i,jbox)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev-1),laddr(2,ilev-1)
              nlist3 = itree(ipointer(24)+ibox-1)
              istart = itree(ipointer(12)+ibox-1)
              iend = itree(ipointer(13)+ibox-1)

              npts = iend-istart+1

              do i=1,nlist3
                jbox = itree(ipointer(25)+(ibox-1)*mnlist3+i-1)
                call h3dmpevalp(nd,zk,rscales(ilev),centers(1,jbox),
     1             rmlexp(iaddr(1,jbox)),nterms(ilev),
     2             targsort(1,istart),npts,pottarg(1,istart),
     3             wlege,nlege,thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpghtarg.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nlist3,istart,iend,npts,i,jbox)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev-1),laddr(2,ilev-1)
              nlist3 = itree(ipointer(24)+ibox-1)
              istart = itree(ipointer(12)+ibox-1)
              iend = itree(ipointer(13)+ibox-1)

              npts = iend-istart+1

              do i=1,nlist3
                jbox = itree(ipointer(25)+(ibox-1)*mnlist3+i-1)
                call h3dmpevalg(nd,zk,rscales(ilev),centers(1,jbox),
     1             rmlexp(iaddr(1,jbox)),nterms(ilev),
     2             targsort(1,istart),npts,pottarg(1,istart),
     3             gradtarg(1,1,istart),wlege,nlege,thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        endif
      enddo

c
c    handle list 4 interactions not handled by plane waves
c    due to high frequency
c

      if(ifcharge.eq.1.and.ifdipole.eq.0) then
        do ilev=1,nlevels
          zk2 = zk*boxsize(ilev)
          if((real(zk2).gt.zkrupbound.or.imag(zk2).gt.zkiupbound).
     1            and.ilev.gt.ilevcutoff) then

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,nlist4,istart,iend,npts,i)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              nlist4 = itree(ipointer(26)+ibox-1)
              do i=1,nlist4
                jbox = itree(ipointer(27)+(ibox-1)*mnlist4+i-1)

c              Form local expansion for all boxes in list3
c              of the current box

                istart = itree(ipointer(10)+jbox-1)
                iend = itree(ipointer(11)+jbox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  call h3dformtac(nd,zk,rscales(ilev),
     1              sourcesort(1,istart),chargesort(1,istart),npts,
     2              centers(1,ibox),nterms(ilev),
     3              rmlexp(iaddr(2,ibox)),wlege,nlege)
                endif
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        enddo
      endif

      if(ifcharge.eq.0.and.ifdipole.eq.1) then
        do ilev=1,nlevels
          zk2 = zk*boxsize(ilev)
          if((real(zk2).gt.zkrupbound.or.imag(zk2).gt.zkiupbound).
     1            and.ilev.gt.ilevcutoff) then

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,nlist4,istart,iend,npts,i)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              nlist4 = itree(ipointer(26)+ibox-1)
              do i=1,nlist4
                jbox = itree(ipointer(27)+(ibox-1)*mnlist4+i-1)

c              Form local expansion for all boxes in list3
c              of the current box

                istart = itree(ipointer(10)+jbox-1)
                iend = itree(ipointer(11)+jbox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  call h3dformtad(nd,zk,rscales(ilev),
     1              sourcesort(1,istart),dipvecsort(1,1,istart),npts,
     2              centers(1,ibox),nterms(ilev),
     3              rmlexp(iaddr(2,ibox)),wlege,nlege)
                endif
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        enddo
      endif

      if(ifcharge.eq.1.and.ifdipole.eq.1) then
        do ilev=1,nlevels
          zk2 = zk*boxsize(ilev)
          if((real(zk2).gt.zkrupbound.or.imag(zk2).gt.zkiupbound).
     1            and.ilev.gt.ilevcutoff) then

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,jbox,nlist4,istart,iend,npts,i)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox=laddr(1,ilev),laddr(2,ilev)
              nlist4 = itree(ipointer(26)+ibox-1)
              do i=1,nlist4
                jbox = itree(ipointer(27)+(ibox-1)*mnlist4+i-1)

c              Form local expansion for all boxes in list3
c              of the current box

                istart = itree(ipointer(10)+jbox-1)
                iend = itree(ipointer(11)+jbox-1)
                npts = iend-istart+1
                if(npts.gt.0) then
                  call h3dformtacd(nd,zk,rscales(ilev),
     1              sourcesort(1,istart),chargesort(1,istart),
     2              dipvecsort(1,1,istart),npts,
     2              centers(1,ibox),nterms(ilev),
     3              rmlexp(iaddr(2,ibox)),wlege,nlege)
                endif
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        enddo
      endif

      call cpu_time(time2)
C$    time2=omp_get_wtime()
      timeinfo(3) = time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== Step 4 (split loc) ===*',i,0)

      call cpu_time(time1)
C$        time1=omp_get_wtime()
      do ilev = 1,nlevels-1
        if(ilev.gt.ilevcutoff) then
          nquad2 = nterms(ilev)*2
          nquad2 = max(6,nquad2)
          ifinit2 = 1
          call legewhts(nquad2,xnodes,wts,ifinit2)
          radius = boxsize(ilev+1)/2*sqrt(3.0d0)

C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,i,jbox,istart,iend,npts)
          do ibox = laddr(1,ilev),laddr(2,ilev)

            npts = 0

            if(ifpghtarg.gt.0) then
              istart = itree(ipointer(12)+ibox-1)
              iend = itree(ipointer(13)+ibox-1)
              npts = npts + iend-istart+1
            endif

            istart = itree(ipointer(14)+ibox-1)
            iend = itree(ipointer(17)+ibox-1)
            npts = npts + iend-istart+1

            if(ifpgh.gt.0) then
              istart = itree(ipointer(10)+ibox-1)
              iend = itree(ipointer(11)+ibox-1)
              npts = npts + iend-istart+1
            endif

            if(npts.gt.0) then
              do i=1,8
                jbox = itree(ipointer(4)+8*(ibox-1)+i-1)
                if(jbox.gt.0) then
                  call h3dlocloc(nd,zk,rscales(ilev),
     1                centers(1,ibox),rmlexp(iaddr(2,ibox)),
     2                nterms(ilev),rscales(ilev+1),centers(1,jbox),
     3                rmlexp(iaddr(2,jbox)),nterms(ilev+1),
     4                radius,xnodes,wts,nquad2)
                endif
              enddo
            endif
          enddo
C$OMP END PARALLEL DO
        endif
      enddo
      call cpu_time(time2)
C$        time2=omp_get_wtime()
      timeinfo(4) = time2-time1

      if(ifprint.ge.1)
     $    call prinf('=== step 5 (eval lo) ===*',i,0)

c     ... step 5, evaluate all local expansions
c

      nquad2 = 2*ntj
      nquad2 = max(6,nquad2)
      ifinit2 = 1

      call legewhts(nquad2,xnodes,wts,ifinit2)
      call cpu_time(time1)
C$        time1=omp_get_wtime()
C

c
cc       shift local expansion to local epxanion at expansion centers
c        (note: this part is not relevant for particle codes.
c        it is relevant only for qbx codes)

      do ilev = 0,nlevels
        if(ilev.gt.ilevcutoff) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,i)
C$OMP$SCHEDULE(DYNAMIC)
          do ibox = laddr(1,ilev),laddr(2,ilev)
            nchild=itree(ipointer(3)+ibox-1)
            if(nchild.eq.0) then
              istart = itree(ipointer(16)+ibox-1)
              iend = itree(ipointer(17)+ibox-1)
              do i=istart,iend
                call h3dlocloc(nd,zk,rscales(ilev),
     1          centers(1,ibox),rmlexp(iaddr(2,ibox)),
     2          nterms(ilev),rscales(ilev),expcsort(1,i),
     3          jsort(1,0,-ntj,i),ntj,radssort(i),xnodes,wts,nquad2)
              enddo
            endif
          enddo
C$OMP END PARALLEL DO
        endif
      enddo

c
cc        evaluate local expansion at source and target
c         locations
c
      do ilev = 0,nlevels
        if(zi*boxsize(ilev).lt.zkiupbound) then
          if(ifpgh.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              nchild=itree(ipointer(3)+ibox-1)
              if(nchild.eq.0) then
                istart = itree(ipointer(10)+ibox-1)
                iend = itree(ipointer(11)+ibox-1)
                npts = iend-istart+1
                call h3dtaevalp(nd,zk,rscales(ilev),centers(1,ibox),
     1           rmlexp(iaddr(2,ibox)),nterms(ilev),
     2           sourcesort(1,istart),npts,pot(1,istart),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpgh.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              nchild=itree(ipointer(3)+ibox-1)
              if(nchild.eq.0) then
                istart = itree(ipointer(10)+ibox-1)
                iend = itree(ipointer(11)+ibox-1)
                npts = iend-istart+1
                call h3dtaevalg(nd,zk,rscales(ilev),centers(1,ibox),
     1         rmlexp(iaddr(2,ibox)),nterms(ilev),sourcesort(1,istart),
     2         npts,pot(1,istart),grad(1,1,istart),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpghtarg.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              nchild=itree(ipointer(3)+ibox-1)
              if(nchild.eq.0) then
                istart = itree(ipointer(12)+ibox-1)
                iend = itree(ipointer(13)+ibox-1)
                npts = iend-istart+1
                call h3dtaevalp(nd,zk,rscales(ilev),centers(1,ibox),
     1         rmlexp(iaddr(2,ibox)),nterms(ilev),targsort(1,istart),
     2         npts,pottarg(1,istart),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifpghtarg.eq.2) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,nchild,istart,iend,npts)
C$OMP$SCHEDULE(DYNAMIC)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              nchild=itree(ipointer(3)+ibox-1)
              if(nchild.eq.0) then
                istart = itree(ipointer(12)+ibox-1)
                iend = itree(ipointer(13)+ibox-1)
                npts = iend-istart+1

                call h3dtaevalg(nd,zk,rscales(ilev),centers(1,ibox),
     1         rmlexp(iaddr(2,ibox)),nterms(ilev),targsort(1,istart),
     2         npts,pottarg(1,istart),gradtarg(1,1,istart),wlege,nlege)
              endif
            enddo
C$OMP END PARALLEL DO
          endif
        endif
      enddo

      call cpu_time(time2)
C$        time2=omp_get_wtime()
      timeinfo(5) = time2 - time1

      if(ifprint .ge. 1)
     $     call prinf('=== STEP 6 (direct) =====*',i,0)
      call cpu_time(time1)
C$        time1=omp_get_wtime()

      if(ifnear.eq.0) goto 1000
c
cc       directly form local expansions for list1 sources
c        at expansion centers.
c        (note: this part is not relevant for particle codes.
c         It is relevant only for qbx codes)

      do ilev=0,nlevels
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarte,iende,nlist1,i,jbox)
C$OMP$PRIVATE(jstart,jend)
        do ibox = laddr(1,ilev),laddr(2,ilev)
          istarte = itree(ipointer(16)+ibox-1)
          iende = itree(ipointer(17)+ibox-1)

          nlist1 = itree(ipointer(20)+ibox-1)

          do i =1,nlist1
            jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)

            jstart = itree(ipointer(10)+jbox-1)
            jend = itree(ipointer(11)+jbox-1)

            call hfmm3dexpc_direct(nd,zk,jstart,jend,istarte,
     1         iende,sourcesort,ifcharge,chargesort,ifdipole,
     2         dipvecsort,expcsort,jsort,scjsort,ntj,
     3         wlege,nlege)
          enddo
        enddo
C$OMP END PARALLEL DO
      enddo

c
cc        directly evaluate potential at sources and targets
c         due to sources in list1

      do ilev=0,nlevels
c
cc           evaluate at the sources
c

        if(ifpgh.eq.1) then
          if(ifcharge.eq.1.and.ifdipole.eq.0) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)

              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcp(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.0.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectdp(nd,zk,sourcesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.1.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcdp(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        endif

        if(ifpgh.eq.2) then
          if(ifcharge.eq.1.and.ifdipole.eq.0) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)

              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcg(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),grad(1,1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.0.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectdg(nd,zk,sourcesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),grad(1,1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.1.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istarts,iends,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istarts = itree(ipointer(10)+ibox-1)
              iends = itree(ipointer(11)+ibox-1)
              npts0 = iends-istarts+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcdg(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,sourcesort(1,istarts),
     2             npts0,pot(1,istarts),grad(1,1,istarts),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        endif

        if(ifpghtarg.eq.1) then
          if(ifcharge.eq.1.and.ifdipole.eq.0) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)

              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcp(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.0.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectdp(nd,zk,sourcesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.1.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcdp(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        endif

        if(ifpghtarg.eq.2) then
          if(ifcharge.eq.1.and.ifdipole.eq.0) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)

              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcg(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),gradtarg(1,1,istartt),
     3             thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.0.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectdg(nd,zk,sourcesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),gradtarg(1,1,istartt),
     3             thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif

          if(ifcharge.eq.1.and.ifdipole.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,istartt,iendt,npts0,nlist1,i,jbox,jstart,jend,npts)
            do ibox = laddr(1,ilev),laddr(2,ilev)
              istartt = itree(ipointer(12)+ibox-1)
              iendt = itree(ipointer(13)+ibox-1)
              npts0 = iendt-istartt+1
              nlist1 = itree(ipointer(20)+ibox-1)
              do i=1,nlist1
                jbox = itree(ipointer(21)+mnlist1*(ibox-1)+i-1)
                jstart = itree(ipointer(10)+jbox-1)
                jend = itree(ipointer(11)+jbox-1)
                npts = jend-jstart+1
                call h3ddirectcdg(nd,zk,sourcesort(1,jstart),
     1             chargesort(1,jstart),
     2             dipvecsort(1,1,jstart),npts,targsort(1,istartt),
     2             npts0,pottarg(1,istartt),gradtarg(1,1,istartt),
     3             thresh)
              enddo
            enddo
C$OMP END PARALLEL DO
          endif
        endif
      enddo

 1000 continue

      call cpu_time(time2)
C$        time2=omp_get_wtime()
      timeinfo(6) = time2-time1
      if(ifprint.ge.1) call prin2('timeinfo=*',timeinfo,6)
      d = 0
      do i = 1,6
         d = d + timeinfo(i)
      enddo

      if(ifprint.ge.1) call prin2('sum(timeinfo)=*',d,1)

      return
      end

c------------------------------------------------------------------
      subroutine hfmm3dexpc_direct(nd,zk,istart,iend,jstart,
     $     jend,source,ifcharge,charge,ifdipole,
     $     dipvec,targ,texps,scj,ntj,wlege,nlege)
c---------------------------------------------------------------
c     This subroutine adds the local expansions due to sources
c     istart to iend in the source array at the expansion centers
c     jstart to jend in the target array to the existing local
c     expansions
c
c     INPUT arguments
c------------------------------------------------------------------
c     nd           in: integer
c                  number of charge densities
c
c     zk           in: double complex
c                  helmholtz parameter
c
c     istart       in:Integer
c                  Starting index in source array whose expansions
c                  we wish to add
c
c     iend         in:Integer
c                  Last index in source array whose expansions
c                  we wish to add
c
c     jstart       in: Integer
c                  First index in target array at which we
c                  wish to compute the expansions
c
c     jend         in:Integer
c                  Last index in target array at which we wish
c                  to compute the expansions
c
c     source       in: double precision(3,ns)
c                  Source locations
c
c     ifcharge     in: Integer
c                  flag for including expansions due to charges
c                  The expansion due to charges will be included
c                  if ifcharge == 1
c
c     charge       in: double complex
c                  Charge at the source locations
c
c     ifdipole     in: Integer
c                 flag for including expansions due to dipoles
c                 The expansion due to dipoles will be included
c                 if ifdipole == 1
c
c     dipvec      in: double complex(3,ns)
c                 Dipole orientation vector at the source locations
c
c     targ        in: double precision(3,nexpc)
c                 Expansion center locations
c
c     scj         in: double precision(nexpc)
c                 scaling parameters for local expansions
c
c     ntj         in: Integer
c                 Number of terms in expansion
c
c     wlege       in: double precision(0:nlege,0:nlege)
c                 precomputed array of recurrence relation
c                 coeffs for Ynm calculation.
c
c    nlege        in: integer
c                 dimension parameter for wlege
c------------------------------------------------------------
c     OUTPUT
c
c   Updated expansions at the targets
c   texps : coeffs for local expansions
c-------------------------------------------------------
        implicit none
c
        integer istart,iend,jstart,jend,ns,j, nlege
        integer nd
        integer ifcharge,ifdipole,ier
        double complex zk
        double precision source(3,*)
        double precision wlege(0:nlege,0:nlege)
        double complex charge(nd,*)
        double complex dipvec(nd,3,*)
        double precision targ(3,*),scj(*)

        integer nlevels,ntj
c
        double complex texps(nd,0:ntj,-ntj:ntj,*)

c
        ns = iend - istart + 1
        if(ifcharge.eq.1.and.ifdipole.eq.0) then
          do j=jstart,jend
            call h3dformtac(nd,zk,scj(j),
     1        source(1,istart),charge(1,istart),ns,
     2        targ(1,j),ntj,texps(1,0,-ntj,j),wlege,nlege)
           enddo
         endif

         if(ifcharge.eq.0.and.ifdipole.eq.1) then
          do j=jstart,jend
            call h3dformtad(nd,zk,scj(j),
     1        source(1,istart),
     2        dipvec(1,1,istart),ns,targ(1,j),ntj,texps(1,0,-ntj,j),
     3        wlege,nlege)
           enddo
         endif

         if(ifcharge.eq.1.and.ifdipole.eq.1) then
          do j=jstart,jend
            call h3dformtacd(nd,zk,scj(j),
     1        source(1,istart),charge(1,istart),
     2        dipvec(1,1,istart),ns,targ(1,j),ntj,texps(1,0,-ntj,j),
     3        wlege,nlege)
           enddo
         endif

c
        return
        end
c------------------------------------------------------------------


      PARAMETER (PI=3.14)
      END


      SUBROUTINE DLASRT( ID, N, D, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     September 30, 1994
*
*     .. Scalar Arguments ..
      CHARACTER          ID
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   D( * )
*     ..
*
*  Purpose
*  =======
*
*  Sort the numbers in D in increasing order (if ID = 'I') or
*  in decreasing order (if ID = 'D' ).
*
*  Use Quick Sort, reverting to Insertion sort on arrays of
*  size <= 20. Dimension of STACK limits N to about 2**32.
*
*  Arguments
*  =========
*
*  ID      (input) CHARACTER*1
*          = 'I': sort D in increasing order;
*          = 'D': sort D in decreasing order.
*
*  N       (input) INTEGER
*          The length of the array D.
*
*  D       (input/output) DOUBLE PRECISION array, dimension (N)
*          On entry, the array to be sorted.
*          On exit, D has been sorted into increasing order
*          (D(1) <= ... <= D(N) ) or into decreasing order
*          (D(1) >= ... >= D(N) ), depending on ID.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            SELECT
      PARAMETER          ( SELECT = 20 )
*     ..
*     .. Local Scalars ..
      INTEGER            DIR, ENDD, I, J, START, STKPNT
      DOUBLE PRECISION   D1, D2, D3, DMNMX, TMP
*     ..
*     .. Local Arrays ..
      INTEGER            STACK( 2, 32 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input paramters.
*
      INFO = 0
      DIR = -1
      IF( LSAME( ID, 'D' ) ) THEN
         DIR = 0
      ELSE IF( LSAME( ID, 'I' ) ) THEN
         DIR = 1
      END IF
      IF( DIR.EQ.-1 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DLASRT', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.LE.1 )
     $   RETURN
*
      STKPNT = 1
      STACK( 1, 1 ) = 1
      STACK( 2, 1 ) = N
   10 CONTINUE
      START = STACK( 1, STKPNT )
      ENDD = STACK( 2, STKPNT )
      STKPNT = STKPNT - 1
      IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
*
*        Do Insertion sort on D( START:ENDD )
*
         IF( DIR.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            DO 30 I = START + 1, ENDD
               DO 20 J = I, START + 1, -1
                  IF( D( J ).GT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 30
                  END IF
   20          CONTINUE
   30       CONTINUE
*
         ELSE
*
*           Sort into increasing order
*
            DO 50 I = START + 1, ENDD
               DO 40 J = I, START + 1, -1
                  IF( D( J ).LT.D( J-1 ) ) THEN
                     DMNMX = D( J )
                     D( J ) = D( J-1 )
                     D( J-1 ) = DMNMX
                  ELSE
                     GO TO 50
                  END IF
   40          CONTINUE
   50       CONTINUE
*
         END IF
*
      ELSE IF( ENDD-START.GT.SELECT ) THEN
*
*        Partition D( START:ENDD ) and stack parts, largest one first
*
*        Choose partition entry as median of 3
*
         D1 = D( START )
         D2 = D( ENDD )
         I = ( START+ENDD ) / 2
         D3 = D( I )
         IF( D1.LT.D2 ) THEN
            IF( D3.LT.D1 ) THEN
               DMNMX = D1
            ELSE IF( D3.LT.D2 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D2
            END IF
         ELSE
            IF( D3.LT.D2 ) THEN
               DMNMX = D2
            ELSE IF( D3.LT.D1 ) THEN
               DMNMX = D3
            ELSE
               DMNMX = D1
            END IF
         END IF
*
         IF( DIR.EQ.0 ) THEN
*
*           Sort into decreasing order
*
            I = START - 1
            J = ENDD + 1
   60       CONTINUE
   70       CONTINUE
            J = J - 1
            IF( D( J ).LT.DMNMX )
     $         GO TO 70
   80       CONTINUE
            I = I + 1
            IF( D( I ).GT.DMNMX )
     $         GO TO 80
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 60
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         ELSE
*
*           Sort into increasing order
*
            I = START - 1
            J = ENDD + 1
   90       CONTINUE
  100       CONTINUE
            J = J - 1
            IF( D( J ).GT.DMNMX )
     $         GO TO 100
  110       CONTINUE
            I = I + 1
            IF( D( I ).LT.DMNMX )
     $         GO TO 110
            IF( I.LT.J ) THEN
               TMP = D( I )
               D( I ) = D( J )
               D( J ) = TMP
               GO TO 90
            END IF
            IF( J-START.GT.ENDD-J-1 ) THEN
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
            ELSE
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = J + 1
               STACK( 2, STKPNT ) = ENDD
               STKPNT = STKPNT + 1
               STACK( 1, STKPNT ) = START
               STACK( 2, STKPNT ) = J
            END IF
         END IF
      END IF
      IF( STKPNT.GT.0 )
     $   GO TO 10
      RETURN
*
*     End of DLASRT
*
      END


! { dg-do run }
! PR fortran/29458 - spurious warning for implied do-loop counter

  integer :: n, i
  i = 10
  n = 5
  n = SUM((/(i,i=1,n)/))

  ! 'i' must not be changed
  IF (i /= 10) STOP 1
END


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Allocatable arrays

	program bq34
	parameter (NT=24)
	common m,mm,n,nn
	data m/1/, mm/3/, n/1/, nn/5/
	integer result(3,8), expect(3,8)
	pointer (p, result)
	data expect /
     +   1, 2, 3, 2, 4, 6, 3, 6,
     +   9, 4, 8, 12, 5, 10, 15, 6,
     +   12, 18, 7, 14, 21, 8, 16, 24 /

	call sub(p)
	call check(result, expect, NT)
	end
	subroutine sub(p)
	common m,mm,n,nn
	pointer (p,ia(:,:))
	nn = 8
	allocate (ia(3,8))
	do i = m, mm
	    do j = n, nn
		ia(i,j) = j*i
	    enddo
	enddo
	end


      program main
        integer*2 i2_1
        parameter (i2_1 = '1'x)
        ! pads to '0001'x and resolves to Int 1

        integer*2 i2_2
        parameter (i2_2 = '10'x)
        ! pads to '0010'x and resolves to Int 16

        integer*2 i2_3
        parameter (i2_3 = '100'x)
        ! pads to '0100'x and resolves to Int 256

        integer*2 i2_4
        parameter (i2_4 = '1000'x)
        ! doesn't pad and resolves to Int 4096

        integer*2 i2_5
        parameter (i2_5 = '7fff'x)
        ! doesn't pad and resolves to Int 32767
        ! the largest number with a positive sign
        !   (most significant bit = 0) for kind 2
        ! in other words, the highest number INTEGER*2 can take

        integer*2 i2_6
        parameter (i2_6 = '8000'x)
        ! doesn't pad and resolves to Int -32768
        ! the largest number with a negative sign
        !   (most significant bit = 1) for kind 2
        ! in other words, the lowest number INTEGER*2 can take

        integer*2 i2_7
        parameter (i2_7 = '8001'x)
        ! doesn't pad and resolves to Int -32767

        integer*2 i2_8
        parameter (i2_8 = '10000'x)
        ! truncates to '0000'x and resolves to Int 0

        integer*2 i2_9
        parameter (i2_9 = '10010'x)
        ! trunactes to '0010'x and resolves to Int 16

        integer*2 i2_10
        parameter (i2_10 = '00010'x)
        ! truncates to '0010'x and resolves to Int 16
      end


*> \brief \b CTZRZF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CTZRZF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A
*> to upper triangular form by means of unitary transformations.
*>
*> The upper trapezoidal matrix A is factored as
*>
*>    A = ( R  0 ) * Z,
*>
*> where Z is an N-by-N unitary matrix and R is an M-by-M upper
*> triangular matrix.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= M.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          On entry, the leading M-by-N upper trapezoidal part of the
*>          array A must contain the matrix to be factorized.
*>          On exit, the leading M-by-M upper triangular part of A
*>          contains the upper triangular matrix R, and elements M+1 to
*>          N of the first M rows of A, with the array TAU, represent the
*>          unitary matrix Z as a product of M elementary reflectors.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is COMPLEX array, dimension (M)
*>          The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.  LWORK >= max(1,M).
*>          For optimum performance LWORK >= M*NB, where NB is
*>          the optimal blocksize.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complexOTHERcomputational
*
*> \par Contributors:
*  ==================
*>
*>    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The N-by-N matrix Z can be computed by
*>
*>     Z =  Z(1)*Z(2)* ... *Z(M)
*>
*>  where each N-by-N Z(k) is given by
*>
*>     Z(k) = I - tau(k)*v(k)*v(k)**H
*>
*>  with v(k) is the kth row vector of the M-by-N matrix
*>
*>     V = ( I   A(:,M+1:N) )
*>
*>  I is the M-by-M identity matrix, A(:,M+1:N)
*>  is the output stored in A on exit from DTZRZF,
*>  and tau(k) is the kth element of the array TAU.
*>
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK computational routine (version 3.4.1) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     April 2012
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IB, IWS, KI, KK, LDWORK, LWKMIN, LWKOPT,
     $                   M1, MU, NB, NBMIN, NX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, CLARZB, CLARZT, CLATRZ
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
*
      IF( INFO.EQ.0 ) THEN
         IF( M.EQ.0 .OR. M.EQ.N ) THEN
            LWKOPT = 1
            LWKMIN = 1
         ELSE
*
*           Determine the block size.
*
            NB = ILAENV( 1, 'CGERQF', ' ', M, N, -1, -1 )
            LWKOPT = M*NB
            LWKMIN = MAX( 1, M )
         END IF
         WORK( 1 ) = LWKOPT
*
         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -7
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTZRZF', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 ) THEN
         RETURN
      ELSE IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
      NBMIN = 2
      NX = 1
      IWS = M
      IF( NB.GT.1 .AND. NB.LT.M ) THEN
*
*        Determine when to cross over from blocked to unblocked code.
*
         NX = MAX( 0, ILAENV( 3, 'CGERQF', ' ', M, N, -1, -1 ) )
         IF( NX.LT.M ) THEN
*
*           Determine if workspace is large enough for blocked code.
*
            LDWORK = M
            IWS = LDWORK*NB
            IF( LWORK.LT.IWS ) THEN
*
*              Not enough workspace to use optimal NB:  reduce NB and
*              determine the minimum value of NB.
*
               NB = LWORK / LDWORK
               NBMIN = MAX( 2, ILAENV( 2, 'CGERQF', ' ', M, N, -1,
     $                 -1 ) )
            END IF
         END IF
      END IF
*
      IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
*
*        Use blocked code initially.
*        The last kk rows are handled by the block method.
*
         M1 = MIN( M+1, N )
         KI = ( ( M-NX-1 ) / NB )*NB
         KK = MIN( M, KI+NB )
*
         DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
            IB = MIN( M-I+1, NB )
*
*           Compute the TZ factorization of the current block
*           A(i:i+ib-1,i:n)
*
            CALL CLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
     $                   WORK )
            IF( I.GT.1 ) THEN
*
*              Form the triangular factor of the block reflector
*              H = H(i+ib-1) . . . H(i+1) H(i)
*
               CALL CLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
     $                      LDA, TAU( I ), WORK, LDWORK )
*
*              Apply H to A(1:i-1,i:n) from the right
*
               CALL CLARZB( 'Right', 'No transpose', 'Backward',
     $                      'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
     $                      LDA, WORK, LDWORK, A( 1, I ), LDA,
     $                      WORK( IB+1 ), LDWORK )
            END IF
   20    CONTINUE
         MU = I + NB - 1
      ELSE
         MU = M
      END IF
*
*     Use unblocked code to factor the last or only block
*
      IF( MU.GT.0 )
     $   CALL CLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
*
      WORK( 1 ) = LWKOPT
*
      RETURN
*
*     End of CTZRZF
*
      END