cc Copyright (C) 2010-2011: Leslie Greengard and Manas Rachh
cc Contact: rachh@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date$
c    $Revision$
c    This file contains the main FMM routines and some related
c    subroutines for evaluating biharmonic sums due to
c    point "charges" and "dipoles".
c
c    bhfmm2d does the biharmonic type sums of complex valued
c    charges and dipoles
c
c    bhfmm2d: charge and dip1,dip2 are complex valued,
c    z are complex numbers. The complex velocity for stokes/
c    displacement for stokes/elasticity problem take the general form
c
c    Stokes:
c    vel(z_i) = \sum_{j \neq i} charge_j *\log|z_i-z_j| +
c                (charge_j)_bar (z_i-z_j)/(z_i-z_j)_bar+
c                dip1/(z_i-z_j) + dip2/(z_i-z_j)_bar-
c                dip1_bar (z_i-z_j)/(z_i-z_j)^2_bar
c
c    The velocity for stokes is related to the goursat functions
c    as vel = \phi(z) + z (d/dz (\phi))_bar+\psi(z)
c
c   The goursat functions are given by
c
c   \phi(z_i) = \sum_{j\neq i} charge_j log(z_i-z_j)+
c                     dip1/(z_i-z_j)
c
c   \psi(z_i) = \sum_{j\neq i} dippar2_bar/(z_i-z_j)+
c               z_j_bar dippar1/(z_i-z_j)^2 +
c               charge_j_bar log(z_i-z_j)- z_j_bar charge_j/(z_i-z_j)
c
c   For stokes and elasticity problems the following derivatives are
c   relevant to physical quantities such as pressure and vorticity
c   for stokes and stresses for elasticity
c
c   1) Analytic gradient (grada)
c      =  \frac{\partial \phi(z_i)}{\partial z}
c
c   2) Anti analytic gradient (gradaa)
c       = z \frac{\partial^2 \phi_(z_i)} {\partial^2 z}_bar +
c         \frac{\partial \psi_(z_i)} {\partial z}
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   bhfmm2dpart - Generalized biharmonic FMM in R^2:
c   evaluate all pairwise particle interactions (ignoring self-interaction)
c
c   bhfmm2dpartself - Generalized biharmonic FMM in R^2:
c   evaluate all pairwise particle interactions (ignoring self-interaction)
c
c   bhfmm2dparttarg - Generalized biharmonic FMM in R^2:
c   evaluate all pairwise particle interactions (ignoring self-interaction)
c   + interactions with targets
c
c   bh2dpartdirect - Generalized biharmonic interactions in R^2:
c   evaluate all pairwise particle interactions (ignoring self-interaction)
c   + interactions with targets via direct O(N^2) algorithm
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
        subroutine bhfmm2dpart(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa)
        implicit real *8 (a-h,o-z)
c
c   Generalized biharmonic FMM in R^2: evaluate all pairwise particle
c   interactions (ignoring self-interaction).
c
c   bhfmm2d: charge and dipstr are complex valued, z are complex numbers.
c
c   bhfmm2d: charge and dip1,dip2 are complex valued,
c   z are complex numbers. The complex velocity for stokes/
c   displacement for stokes/elasticity problem take the general form
c
c   Stokes:
c   vel(z_i) = \sum_{j \neq i} charge_j *\log|z_i-z_j| +
c                (charge_j)_bar (z_i-z_j)/(z_i-z_j)_bar+
c                dip1/(z_i-z_j) + dip2/(z_i-z_j)_bar-
c                dip1_bar (z_i-z_j)/(z_i-z_j)^2_bar
c
c   The velocity for stokes is related to the goursat functions
c   as vel = \phi(z) + z (d/dz (\phi))_bar+\psi(z)
c
c   The goursat functions are given by
c
c   \phi(z_i) = \sum_{j\neq i} charge_j log(z_i-z_j)+
c                     dip1/(z_i-z_j)
c
c   \psi(z_i) = \sum_{j\neq i} dippar2_bar/(z_i-z_j)+
c               z_j_bar dippar1/(z_i-z_j)^2 +
c               charge_j_bar log(z_i-z_j)- z_j_bar charge_j/(z_i-z_j)
c
c   For stokes and elasticity problems the following derivatives are
c   relevant to physical quantities such as pressure and vorticity
c   for stokes and stresses for elasticity
c
c   1) Analytic gradient (grada)
c      =  \frac{\partial \phi(z_i)}{\partial z}
c
c   2) Anti analytic gradient (gradaa)
c       = z \frac{\partial^2 \phi_(z_i)} {\partial^2 z}_bar +
c         \frac{\partial \psi_(z_i)} {\partial z}
c
c   The main FMM routine permits both evaluation at sources
c   and at a collection of targets.
c   This subroutine is used to simplify the user interface
c   (by setting the number of targets to zero) and calling the more
c   general FMM.
c
c   See below for explanation of calling sequence arguments.
c
        real *8 source(2,*)
        complex *16 charge(*)
        complex *16 dip1(*)
        complex *16 dip2(*)
        complex *16 ima
        complex *16 vel(*)
        complex *16 grada(*)
        complex *16 gradaa(*)
c
        real *8 target(2,1)
        complex *16 veltarg(1)
        complex *16 gradatarg(1)
        complex *16 gradaatarg(1)
c
        data ima/(0.0d0,1.0d0)/
c
        ntarget=0
        ifveltarg=0
        ifgradatarg=0
        ifgradaatarg=0
c
        call bhfmm2dparttarg(ier,iprec,nsource,source,
     $  ifcharge,charge,ifdipole,dip1,dip2,
     $  ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $  ntarget,target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $  ifgradaatarg,gradaatarg)
c
        return
        end
c
c*************************************************************************
        subroutine bhfmm2dpartself(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa)
        implicit real *8 (a-h,o-z)
c
c   Generalized biharmonic FMM in R^2: evaluate all pairwise particle
c   interactions (ignoring self-interaction).
c
c   Self-interactions are not included.
c
c   bhfmm2d: charge and dipstr are complex valued, z are complex numbers.
c
c   bhfmm2d: charge and dip1,dip2 are complex valued,
c   z are complex numbers. The complex velocity for stokes/
c   displacement for stokes/elasticity problem take the general form
c
c   Stokes:
c   vel(z_i) = \sum_{j \neq i} charge_j *\log|z_i-z_j| +
c                (charge_j)_bar (z_i-z_j)/(z_i-z_j)_bar+
c                dip1/(z_i-z_j) + dip2/(z_i-z_j)_bar-
c                dip1_bar (z_i-z_j)/(z_i-z_j)^2_bar
c
c   The velocity for stokes is related to the goursat functions
c   as vel = \phi(z) + z (d/dz (\phi))_bar+\psi(z)
c
c   The goursat functions are given by
c
c   \phi(z_i) = \sum_{j\neq i} charge_j log(z_i-z_j)+
c                     dip1/(z_i-z_j)
c
c   \psi(z_i) = \sum_{j\neq i} dippar2_bar/(z_i-z_j)+
c               z_j_bar dippar1/(z_i-z_j)^2 +
c               charge_j_bar log(z_i-z_j)- z_j_bar charge_j/(z_i-z_j)
c
c   For stokes and elasticity problems the following derivatives are
c   relevant to physical quantities such as pressure and vorticity
c   for stokes and stresses for elasticity
c
c   1) Analytic gradient (grada)
c      =  \frac{\partial \phi(z_i)}{\partial z}
c
c   2) Anti analytic gradient (gradaa)
c       = z \frac{\partial^2 \phi_(z_i)} {\partial^2 z}_bar +
c         \frac{\partial \psi_(z_i)} {\partial z}
c
c   The main FMM routine permits both evaluation at sources
c   and at a collection of targets.
c
c   The main FMM routine permits both evaluation at sources
c   and at a collection of targets.
c   This subroutine is used to simplify the user interface
c   (by setting the number of targets to zero) and calling the more
c   general FMM.
c
c   See below for explanation of calling sequence arguments.
c
        real *8 source(2,*)
        complex *16 charge(*)
        complex *16 dip1(*)
        complex *16 dip2(*)
        complex *16 ima
        complex *16 vel(*)
        complex *16 grada(*)
        complex *16 gradaa(*)
c
        real *8 target(2,1)
        complex *16 veltarg
        complex *16 gradatarg
        complex *16 gradaatarg
c
        data ima/(0.0d0,1.0d0)/
c
        ntarget=0
        ifveltarg=0
        ifgradatarg=0
        ifgradaatarg=0
c
        call bhfmm2dparttarg(ier,iprec,nsource,source,
     $  ifcharge,charge,ifdipole,dip1,dip2,
     $  ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $  ntarget,target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $  ifgradaatarg,gradaatarg)
c
        return
        end
c
c***********************************************************************
        subroutine bhfmm2dparttarg(ier,iprec,nsource,source,
     $  ifcharge,charge,ifdipole,dip1,dip2,
     $  ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $  ntarget,target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $  ifgradaatarg,gradaatarg)
        implicit real *8 (a-h,o-z)
c
c   Generalized biharmonic FMM in R^2: evaluate all pairwise particle
c   interactions (ignoring self-interaction)
c   and interactions with targets.
c
c   Self-interactions are not included.
c
c   bhfmm2d: charge and dipstr are complex valued, z are complex numbers.
c
c   bhfmm2d: charge and dip1,dip2 are complex valued,
c   z are complex numbers. The complex velocity for stokes/
c   displacement for stokes/elasticity problem take the general form
c
c   Stokes:
c   vel(z_i) = \sum_{j \neq i} charge_j *\log|z_i-z_j| +
c                (charge_j)_bar (z_i-z_j)/(z_i-z_j)_bar+
c                dip1/(z_i-z_j) + dip2/(z_i-z_j)_bar-
c                dip1_bar (z_i-z_j)/(z_i-z_j)^2_bar
c
c   The velocity for stokes is related to the goursat functions
c   as vel = \phi(z) + z (d/dz (\phi))_bar+\psi(z)
c
c   The goursat functions are given by
c
c   \phi(z_i) = \sum_{j\neq i} charge_j log(z_i-z_j)+
c                     dip1/(z_i-z_j)
c
c   \psi(z_i) = \sum_{j\neq i} dippar2_bar/(z_i-z_j)+
c               z_j_bar dippar1/(z_i-z_j)^2 +
c               charge_j_bar log(z_i-z_j)- z_j_bar charge_j/(z_i-z_j)
c
c   For stokes and elasticity problems the following derivatives are
c   relevant to physical quantities such as pressure and vorticity
c   for stokes and stresses for elasticity
c
c   1) Analytic gradient (grada)
c      =  \frac{\partial \phi(z_i)}{\partial z}
c
c   2) Anti analytic gradient (gradaa)
c       = z \frac{\partial^2 \phi_(z_i)} {\partial^2 z}_bar +
c         \frac{\partial \psi_(z_i)} {\partial z}
c
c   The main FMM routine permits both evaluation at sources
c   and at a collection of targets.
c
c
c   This is primarily a memory management code.
c   The actual work is carried out in subroutine cfmm2dparttargmain.
c-----------------------------------------------------------------------
c   INPUT PARAMETERS:
c
c   iprec:  FMM precision flag
c
c                 -2 => tolerance =.5d0
c                 -1 => tolerance =.5d-1
c                  0 => tolerance =.5d-2
c                  1 => tolerance =.5d-3
c                  2 => tolerance =.5d-6
c                  3 => tolerance =.5d-9
c                  4 => tolerance =.5d-12
c                  5 => tolerance =.5d-15
c
c       nsource: integer:  number of sources
c       source: real *8 (2,nsource):  source locations

c   ifcharge:  charge computation flag
c              ifcharge = 1   =>  include charge contribution
c                                     otherwise do not
c   charge: complex *16 (nsource): charge strengths

c   ifdipole:  dipole computation flag
c              ifdipole = 1   =>  include dipole contribution
c                                     otherwise do not
c   dip1: complex *16 (nsource): dip1 strengths
c   dip2: complex *16 (nsource): dip2 strengths.
c
c   ifvel:  velocity flag (1=compute velocity, otherwise no)
c   ifgrada: Analytic gradient flag
c            (1=compute analytic gradient, otherwise no)
c   ifgradaa: Anti analytic gradient flag
c               (1=compute anti analytic gradient, otherwise no)

c   ntarget: integer:  number of targets
c   target: real *8 (2,ntarget):  target locations

c   ifveltarg:  target velocity flag
c             (1=compute velocity, otherwise no)
c   ifgradtarg:  target analytic gradient flag
c             (1=compute analytic gradient, otherwise no)
c   ifgradaatarg:  target anti analytic flag
c             (1=compute anti analytic, otherwise no)
c--------------------------------------------------------------------
c   OUTPUT PARAMETERS:
c
c   ier   =  error return code
c                ier=0     =>  normal execution
c                ier=4     =>  cannot allocate tree workspace
c                ier=8     =>  cannot allocate bulk FMM  workspace
c                ier=16    =>  cannot allocate mpole expansion
c                              workspace in FMM
c
c   vel: complex *16 (nsource): velocity at source locations
c   grada: complex *16 (nsource): analytic gradient at source locations
c   gradaa: complex *16 (nsource):
c                         anti analytic gradient at source locations
c   veltarg: complex *16 (ntarget): velocity at target locations
c   gradatarg: complex *16 (ntarget):
c                         analytic gradient  at target locations
c   gradaatarg: complex *16 (ntarget):
c                         anti analytic gradient at target locations
c
        real *8 source(2,*)
        complex *16 charge(*)
        complex *16 dip1(*)
        complex *16 dip2(*)
        complex *16 ima
        complex *16 vel(*)
        complex *16 grada(*)
        complex *16 gradaa(*)
c
        real *8 target(2,*)
        complex *16 veltarg(*)
        complex *16 gradatarg(*)
        complex *16 gradaatarg(*)
c
        real *8 timeinfo(10)
c
        real *8 center(2)
c
c
c     Note: various arrays dimensioned here to 200.
c     That allows for 200 levels of refinement, which is
c     more than enough for any non-pathological case.
c
        integer laddr(2,200)
        real *8 scale(0:200)
        real *8 bsize(0:200)
        integer nterms(0:200)
c
        complex *16 vtemp,gatemp,gaatemp
c
        integer box(15)
        real *8 center0(2),corners0(2,4)
c
        integer box1(15)
        real *8 center1(2),corners1(2,4)
c
        real *8, allocatable :: w(:)
        real *8, allocatable :: wlists(:)
        real *8, allocatable :: wrmlexp(:)
c
        data ima/(0.0d0,1.0d0)/
c
        ier=0
        lused7=0
c
        done=1
        pi=4*atan(done)
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
c     set fmm tolerance based on iprec flag.
c
        if( iprec .eq. -2 ) epsfmm=.5d-0
        if( iprec .eq. -1 ) epsfmm=.5d-1
        if( iprec .eq. 0 ) epsfmm=.5d-2
        if( iprec .eq. 1 ) epsfmm=.5d-3
        if( iprec .eq. 2 ) epsfmm=.5d-6
        if( iprec .eq. 3 ) epsfmm=.5d-9
        if( iprec .eq. 4 ) epsfmm=.5d-12
        if( iprec .eq. 5 ) epsfmm=.5d-15
        if( iprec .eq. 6 ) epsfmm=0
c
        if(ifprint .eq. 1) call prin2('epsfmm=*',epsfmm,1)
c
c     set criterion for box subdivision (number of sources per box)
c
        if( iprec .eq. -2 ) nbox=3
        if( iprec .eq. -1 ) nbox=5
        if( iprec .eq. 0 ) nbox=8
        if( iprec .eq. 1 ) nbox=10
        if( iprec .eq. 2 ) nbox=15
        if( iprec .eq. 3 ) nbox=20
        if( iprec .eq. 4 ) nbox=25
        if( iprec .eq. 5 ) nbox=45
        if( iprec .eq. 6 ) nbox=nsource+ntarget
c
        if(ifprint .eq. 1) call prinf('nbox=*',nbox,1)
c
c       create quad-tree data structure
        t1=second()
C$      t1=omp_get_wtime()
        ntot = 100*(nsource+ntarget)+10000
        do ii = 1,10
           allocate (wlists(ntot))
           call bhfmm2dparttree(ier,iprec,
     $     nsource,source,ntarget,target,
     $     nbox,epsfmm,iisource,iitarget,iwlists,lwlists,
     $     nboxes,laddr,nlev,center,size,
     $     wlists,ntot,lused7)
           if (ier.ne.0) then
              deallocate(wlists)
              ntot = ntot*1.5
              call prinf(' increasing allocation, ntot is *',ntot,1)
           else
              goto 1200
           endif
        enddo
1200    continue

        if (ier.ne.0) then
           call prinf(' exceeded max allocation, ntot is *',ntot,1)
           ier = 4
           return
        endif
        t2=second()
C$      t2=omp_get_wtime()
        if( ifprint .eq. 1 ) call prin2('time in d2tstcr=*',t2-t1,1)
c
c     lused7 is counter that steps through workspace,
c     keeping track of total memory used.
c
        lused7=1
c
c       ... prepare data structures
c
        do i = 0,nlev
           scale(i) = 1.0d0
           boxsize = abs((size/2.0**i))
           scale(i) = boxsize
        enddo
c
        if(ifprint .eq. 1) call prin2('scale=*',scale,nlev+1)
c
c       carve up workspace further
c
c     isourcesort is pointer for sorted source coordinates
c     itargetsort is pointer for sorted target locations
c     ichargesort is pointer for sorted charge densities
c     idip1sort is pointer for sorted dipole strength 1
c     idip2sort is pointer for sorted dipole strength 2
c
        isourcesort = lused7 + 5
        lsourcesort = 2*nsource
        itargetsort = isourcesort+lsourcesort
        ltargetsort = 2*ntarget
        ichargesort = itargetsort+ltargetsort
        lchargesort = 2*nsource
        idip1sort = ichargesort+lchargesort
        if (ifdipole.eq.1) then
          ldip1 = 2*nsource
          ldip2 = 2*nsource
        else
          ldip1 = 2
          ldip2 = 2
        endif
        idip2sort = idip1sort + ldip1
        lused7 = idip2sort + ldip2
c
c       ... allocate the potential and gradient arrays
c
        ivel = lused7
        lvel = 2*nsource
        lused7=lused7+lvel
c
        igrada = lused7
        if(ifgrada.eq. 1) then
            lgrada = 2*nsource
        else
            lgrada=2
        endif
        lused7=lused7+lgrada
c
        igradaa = lused7
        if(ifgradaa .eq. 1) then
            lgradaa=2*nsource
        else
            lgradaa=2
        endif
        lused7=lused7+lgradaa
c
        iveltarg = lused7
        lveltarg = 2*ntarget
        lused7=lused7+lveltarg
c
        igradatarg = lused7
        if( ifgradatarg .eq. 1) then
            lgradatarg=2*ntarget
        else
            lgradatarg=2
        endif
        lused7=lused7+lgradatarg
c
        igradaatarg = lused7
        if(ifgradaatarg .eq. 1) then
            lgradaatarg = 2*ntarget
        else
            lgradaatarg=2
        endif
        lused7=lused7+lgradaatarg
c
        if(ifprint .eq. 1) call prinf(' lused7 is *',lused7,1)
c
c       based on FMM tolerance, compute expansion lengths nterms(i)
c
        nmax = 0

        do i = 0,nlev
           bsize(i)=size/2.0d0**i
           call l2dterms(epsfmm, nterms(i), ier)
           if (nterms(i).gt. nmax .and. i.ge. 2) nmax = nterms(i)
        enddo
c
        if (ifprint.eq.1)
     $     call prin2('in bhfmm2dpart, bsize(0)=*',
     $     abs(bsize(0)),1)
c
        if (ifprint.eq.1) call prin2('bsize=*',bsize,nlev+1)
        if (ifprint.eq.1) call prinf('nterms=*',nterms,nlev+1)
c
c
c     Multipole and local expansions will be held in workspace
c     in locations pointed to by array iaddr(10,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
        iiaddr = lused7
        imptemp1 = iiaddr + 10*nboxes
        lmptemp1 = (2*nmax+1)*2
        lused7 = imptemp1 + lmptemp1

        imptemp2 = lused7
        lmptemp2 = (2*nmax+1)*2
        lused7 = imptemp2 + lmptemp2

        imptemp3 = lused7
        lmptemp3 = (2*nmax+1)*2
        lused7 = imptemp3 + lmptemp3

        imptemp4 = lused7
        lmptemp4 = (2*nmax+1)*2
        lused7 = imptemp4 + lmptemp4

        imptemp5 = lused7
        lmptemp5 = (2*nmax+1)*2
        lused7 = imptemp5 + lmptemp5

        allocate(w(lused7),stat=ier)
        if (ier.ne.0) then
           call prinf(' cannot allocate bulk FMM workspace,
     1                  lused7 is *',lused7,1)
           ier = 8
           return
        endif
c
c     reorder sources, targets so that each box holds
c     contiguous list of source/target numbers.

c
        call bh2dreorder(nsource,source,ifcharge,charge,
     $  wlists(iisource),ifdipole,dip1,dip2,w(isourcesort),
     1  w(ichargesort),w(idip1sort),w(idip2sort))
c
        call bh2dreordertarg(ntarget,target,wlists(iitarget),
     $  w(itargetsort))
c
        if(ifprint .eq. 1) then
           call prinf('finished reordering=*',ier,1)
           call prinf('ier=*',ier,1)
           call prinf('nboxes=*',nboxes,1)
           call prinf('nlev=*',nlev,1)
           call prinf('nboxes=*',nboxes,1)
           call prinf('lused7=*',lused7,1)
        endif
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 bh2dmpalloc(wlists(iwlists),w(iiaddr),nboxes,lmptot,nterms)
        if(ifprint .eq. 1) call prinf(' lmptot is *',lmptot,1)
c
        irmlexp = 1
        lused7 = irmlexp + lmptot
        if(ifprint .eq. 1) call prinf(' lused7 is *',lused7,1)
        allocate(wrmlexp(lused7),stat=ier)
        if (ier.ne.0) then
           call prinf(' cannot allocate mpole expansion workspace,
     1     lused7 is *',lused7,1)
           ier = 16
           return
        endif
c
c     Memory allocation is complete.
c     Call main fmm routine. There are, unfortunately, a lot
c     of parameters here. ifevalfar and ifevalloc determine
c     whether far gradient and local gradients (respectively) are to
c     be evaluated. Setting both to 1 means that both will be
c     computed (which is the normal scenario).
c
        ifevalfar=1
        ifevalloc=1
c
        t1=second()
C$      t1=omp_get_wtime()
        call bhfmm2dparttargmain(ier,iprec,
     $  ifevalfar,ifevalloc,
     $  nsource,w(isourcesort),wlists(iisource),
     $  ifcharge,w(ichargesort),
     $  ifdipole,w(idip1sort),w(idip2sort),
     $  ifvel,w(ivel),ifgrada,w(igrada),ifgradaa,w(igradaa),
     $  ntarget,w(itargetsort),wlists(iitarget),
     $  ifveltarg,w(iveltarg),ifgradatarg,w(igradatarg),
     $  ifgradaatarg,w(igradaatarg),
     $  epsfmm,w(iiaddr),wrmlexp(irmlexp),w(imptemp1),lmptemp1,
     $  w(imptemp2),lmptemp2,w(imptemp3),lmptemp3,w(imptemp4),
     $  lmptemp4,w(imptemp5),lmptemp5,
     $  nboxes,laddr,nlev,scale,bsize,nterms,
     $  wlists(iwlists),lwlists)
        t2=second()
C$      t2=omp_get_wtime()
        if( ifprint .eq. 1 ) call prin2('time in fmm main=*',t2-t1,1)
c
c       parameter ier from targmain routine is currently
c       meaningless, reset to 0
        if( ier .ne. 0 ) ier = 0
c
        if(ifprint .eq. 1) call prinf('lwlists=*',lwlists,1)
        if(ifprint .eq. 1) then
           call prinf('lused total=*',lused7,1)
           call prinf('lused total(k)=*',lused7/1000,1)
           call prinf('lused total(M)=*',lused7/1000000,1)
        endif
c
        if(ifprint .eq. 1)
     $     call prin2('memory / point = *',(lused7)/dble(nsource),1)
c
c
        if(ifvel .eq. 1)
     $     call bh2dpsort(nsource,wlists(iisource),w(ivel),vel)
        if(ifgrada .eq. 1)
     $     call bh2dpsort(nsource,wlists(iisource),w(igrada),grada)
        if(ifgradaa .eq. 1)
     $     call bh2dpsort(nsource,wlists(iisource),w(igradaa),gradaa)
c
        if(ifveltarg .eq. 1 )
     $     call bh2dpsort(ntarget,wlists(iitarget),w(iveltarg),veltarg)
        if(ifgradatarg .eq. 1)
     $     call bh2dpsort(ntarget,wlists(iitarget),w(igradatarg),
     $     gradatarg)
        if(ifgradaatarg .eq. 1)
     $   call bh2dpsort(ntarget,wlists(iitarget),w(igradaatarg),
     $   gradaatarg)
c
        return
        end
c
c***********************************************************************
        subroutine bhfmm2dparttargmain(ier,iprec,
     $  ifevalfar,ifevalloc,
     $  nsource,sourcesort,isource,
     $  ifcharge,chargesort,
     $  ifdipole,dip1sort,dip2sort,
     $  ifvel,vel,ifgrada,grada,ifgradaa,gradaa,ntarget,
     $  targetsort,itarget,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $  ifgradaatarg,gradaatarg,
     $  epsfmm,iaddr,rmlexp,mptemp1,lmptemp1,mptemp2,lmptemp2,
     $  mptemp3,lmptemp3,mptemp4,lmptemp4,mptemp5,lmptemp5,
     $  nboxes,laddr,nlev,scale,bsize,nterms,
     $  wlists,lwlists)
        implicit real *8 (a-h,o-z)
        real *8 sourcesort(2,*)
        integer isource(*)
        complex *16 chargesort(*)
        complex *16 dip1sort(*)
        complex *16 dip2sort(*)
        complex *16 ima
        complex *16 vel(*)
        complex *16 grada(*)
        complex *16 gradaa(*)
        real *8 targetsort(2,*)
        integer itarget(*)
        complex *16 veltarg(*)
        complex *16 gradatarg(*)
        complex *16 gradaatarg(*)
        real *8 wlists(*)
        integer iaddr(10,nboxes)
        real *8 rmlexp(*)
        complex *16 mptemp1(lmptemp1)
        complex *16 mptemp2(lmptemp2)
        complex *16 mptemp3(lmptemp3)
        complex *16 mptemp4(lmptemp4)
        complex *16 mptemp5(lmptemp5)
        real *8 timeinfo(10)
        real *8 center(3)
        integer laddr(2,200)
        real *8 scale(0:200)
        real *8 bsize(0:200)
        integer nterms(0:200)
        integer list(10 000)
        complex *16 vtemp,gatemp,gaatemp
        integer box(15)
        real *8 center0(2),corners0(2,4)
        integer box1(15)
        real *8 center1(2),corners1(2,4)
        integer nterms_eval(4,0:200)
c
        data ima/(0.0d0,1.0d0)/
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     Prints timing breakdown, list information, and other things if ifprint=2.
c
        ifprint=0
c
c
c       ... set the potential and gradient to zero
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
        do i=1,nsource
           if( ifvel .eq. 1) vel(i)=0
           if( ifgrada .eq. 1) grada(i)=0
           if( ifgradaa .eq. 1) gradaa(i)=0
        enddo
C$OMP END PARALLEL DO
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
        do i=1,ntarget
           if( ifveltarg .eq. 1) veltarg(i)=0
           if( ifgradatarg .eq. 1) then
              gradatarg(i)=0
           endif
           if( ifgradaatarg .eq. 1) then
              gradaatarg(i)=0
           endif
        enddo
C$OMP END PARALLEL DO
c
        do i=1,10
           timeinfo(i)=0
        enddo
c
c
        if( ifevalfar .eq. 0 ) goto 8000
c
        if (ifprint .ge. 2) then
           call prinf('nterms_eval=*',nterms_eval,4*(nlev+1))
        endif
c
c       ... set all multipole and local expansions to zero
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,level,ier)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do ibox = 1,nboxes
           call d2tgetb(ier,ibox,box,center0,corners0,wlists)
           level=box(1)
           if( level .ge. 2 ) then
             call bh2dzero(rmlexp(iaddr(1,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(2,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(3,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(4,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(5,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(6,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(7,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(8,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(9,ibox)),nterms(level))
             call bh2dzero(rmlexp(iaddr(10,ibox)),nterms(level))
           endif
        enddo
C$OMP END PARALLEL DO
c
c
        if(ifprint .ge. 1) then
           call prinf('=== STEP 1 (form mp) ====*',i,0)
        endif
        t1=second()
C$      t1=omp_get_wtime()
c
c       ... step 1, locate all charges, assign them to boxes, and
c       form multipole expansions
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,level,npts,nkids,radius)
C$OMP$PRIVATE(mptemp1,lused,ier,i,j,vtemp,gatemp,gaatemp,cd)
C$OMP$PRIVATE(mptemp2,mptemp3,mptemp4,mptemp5)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
        do 1200 ibox=1,nboxes
c
           call d2tgetb(ier,ibox,box,center0,corners0,wlists)
           call d2tnkids(box,nkids)
c
           level=box(1)
           if( level .lt. 2 ) goto 1200
c
c
           if (ifprint .ge. 2) then
              call prinf('ibox=*',ibox,1)
              call prinf('box=*',box,15)
              call prinf('nkids=*',nkids,1)
           endif
c
           if (nkids .eq. 0) then
              npts=box(10)
              if (ifprint .ge. 2) then
                 call prinf('npts=*',npts,1)
                 call prinf('isource=*',isource(box(9)),box(10))
              endif
           endif
c
c       ... prune all sourceless boxes
c
c       ... form multipole expansions
           if( box(10) .eq. 0 ) goto 1200
           if (nkids .eq. 0) then
               radius = (corners0(1,1) - center0(1))**2
               radius = radius + (corners0(2,1) - center0(2))**2
               radius = sqrt(radius)
c
               call bh2dzero(rmlexp(iaddr(1,ibox)),nterms(level))
               call bh2dzero(rmlexp(iaddr(2,ibox)),nterms(level))
               call bh2dzero(rmlexp(iaddr(3,ibox)),nterms(level))
               call bh2dzero(rmlexp(iaddr(4,ibox)),nterms(level))
               call bh2dzero(rmlexp(iaddr(5,ibox)),nterms(level))
               if_use_trunc = 0

               call bh2dformmp(ier,scale(level),
     1         sourcesort(1,box(9)),ifcharge,chargesort(box(9)),
     2         ifdipole,dip1sort(box(9)),dip2sort(box(9)),npts,
     3         center0,nterms(level),rmlexp(iaddr(1,ibox)),
     4         rmlexp(iaddr(2,ibox)),rmlexp(iaddr(3,ibox)),
     5         rmlexp(iaddr(4,ibox)),rmlexp(iaddr(5,ibox)))

             endif
 1200     continue
C$OMP END PARALLEL DO
c
          t2=second()
C$      t2=omp_get_wtime()
          timeinfo(1)=t2-t1
c
          if(ifprint .ge. 1) then
              call prinf('=== STEP 2 (form lo) ====*',i,0)
          endif
          t1=second()
C$      t1=omp_get_wtime()
c       ... step 2, adaptive part, form local expansions,
c           or evaluate the potentials and gradients directly
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,level0,itype,list,nlist)
C$OMP$PRIVATE(jbox,box1,center1,corners1,level1,ifdirect3,radius)
C$OMP$PRIVATE(lused,ier,i,j,vtemp,gatemp,gaatemp,cd,ilist,npts)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
          do 3251 ibox=1,nboxes
             call d2tgetb(ier,ibox,box,center0,corners0,wlists)
c
             itype=4
             call d2tgetl(ier,ibox,itype,list,nlist,wlists)
             if (nlist .gt. 0) then
                if (ifprint .ge. 2) then
                    call prinf('ibox=*',ibox,1)
                    call prinf('list3=*',list,nlist)
                endif
             endif
c       ... note that lists 3 and 4 are dual
c
c       ... form local expansions for all boxes in list 3
c       ... if target is childless, evaluate directly (if cheaper)
c
             do 3250 ilist=1,nlist
                 jbox=list(ilist)
                 call d2tgetb(ier,jbox,box1,center1,corners1,wlists)
c
                 npts=box1(10)
                 if( npts .eq. 0 ) goto 3250
c
                 level0=box(1)
                 level1=box1(1)
c
                 ifdirect3 = 0
c
                 if( ifdirect3 .eq. 0 ) then
                     npts=box1(10)
                     if_use_trunc = 0

                     call bh2dformta_add(ier,scale(level0),
     $               sourcesort(1,box1(9)),ifcharge,
     1               chargesort(box1(9)),ifdipole,dip1sort(box1(9)),
     2               dip2sort(box1(9)),npts,center0,nterms(level0),
     3               rmlexp(iaddr(6,ibox)),rmlexp(iaddr(7,ibox)),
     4               rmlexp(iaddr(8,ibox)),rmlexp(iaddr(9,ibox)),
     5               rmlexp(iaddr(10,ibox)))
                 else
                    call bhfmm2dpart_direct(box1,box,sourcesort,
     $              ifcharge,chargesort,ifdipole,dip1sort,dip2sort,
     $              ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $              targetsort,ifveltarg,veltarg,ifgradatarg,
     $              gradatarg,ifgradaatarg,gradaatarg)
                 endif
 3250         continue
 3251     continue
C$OMP END PARALLEL DO
          t2=second()
C$      t2=omp_get_wtime()
          timeinfo(2)=t2-t1
c
          if(ifprint .ge. 1)
     $         call prinf('=== STEPS 3,4,5 ====*',i,0)
          ifprune_list2 = 1
          if (ifvel.eq.1) ifprune_list2 = 0
          if (ifgrada.eq.1) ifprune_list2 = 0
          if (ifgradaa.eq.1) ifprune_list2 = 0
          call bhfmm2d_list2
     $    (bsize,nlev,laddr,scale,nterms,rmlexp,iaddr,epsfmm,
     $    timeinfo,wlists,mptemp1,lmptemp1,mptemp2,lmptemp2,
     $    mptemp3,lmptemp3,mptemp4,lmptemp4,
     $    mptemp5,lmptemp5,ifprune_list2)
c
          if(ifprint .ge. 1)
     $       call prinf('=== STEP 6 (eval mp) ====*',i,0)
          t1=second()
C$      t1=omp_get_wtime()
c       ... step 6, adaptive part, evaluate multipole expansions,
c           or evaluate the potentials and gradients directly
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,itype,list,nlist)
C$OMP$PRIVATE(jbox,box1,center1,corners1,level1,ifdirect4,radius)
C$OMP$PRIVATE(lused,ier,i,j,vtemp,gatemp,gaatemp,cd,ilist,level)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
          do 3252 ibox=1,nboxes
             call d2tgetb(ier,ibox,box,center0,corners0,wlists)
             itype=3
             call d2tgetl(ier,ibox,itype,list,nlist,wlists)
             if (nlist .gt. 0) then
                if (ifprint .ge. 2) then
                   call prinf('ibox=*',ibox,1)
                   call prinf('list4=*',list,nlist)
                endif
             endif
c       ... note that lists 3 and 4 are dual
c
c       ... evaluate multipole expansions for all boxes in list 4
c       ... if source is childless, evaluate directly (if cheaper)
c
             do ilist=1,nlist
                jbox=list(ilist)
                call d2tgetb(ier,jbox,box1,center1,corners1,wlists)
                level=box1(1)
c
                ifdirect4 = 0
                if (ifdirect4 .eq. 0) then
                   if( box(10) .gt. 0) then
                      call bh2dmpevalall(scale(level),center1,
     1                rmlexp(iaddr(1,jbox)),rmlexp(iaddr(2,jbox)),
     2                rmlexp(iaddr(3,jbox)),rmlexp(iaddr(4,jbox)),
     3                rmlexp(iaddr(5,jbox)),nterms(level),
     4                sourcesort(1,box(9)),box(10),vel(box(9)),
     5                ifgrada,grada(box(9)),ifgradaa,gradaa(box(9)))
                   endif

                   if( box(12) .gt. 0 ) then
                      call bh2dmpevalall(scale(level),center1,
     1                rmlexp(iaddr(1,jbox)),rmlexp(iaddr(2,jbox)),
     2                rmlexp(iaddr(3,jbox)),rmlexp(iaddr(4,jbox)),
     3                rmlexp(iaddr(5,jbox)),nterms(level),
     4                targetsort(1,box(11)),box(12),veltarg(box(11)),
     5                ifgradatarg,gradatarg(box(11)),
     6                ifgradaatarg,gradaatarg(box(11)))
                   endif
                else
                   call bhfmm2dpart_direct(box1,box,sourcesort,
     $             ifcharge,chargesort,ifdipole,dip1sort,dip2sort,
     $             ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $             targetsort,ifveltarg,veltarg,ifgradatarg,
     $             gradatarg,ifgradaatarg,gradaatarg)
                endif
             enddo
 3252     continue
C$OMP END PARALLEL DO
          t2=second()
C$      t2=omp_get_wtime()
          timeinfo(6)=t2-t1
          if(ifprint .ge. 1)
     $       call prinf('=== STEP 7 (eval lo) ====*',i,0)
          t1=second()
C$      t1=omp_get_wtime()
c
c       ... step 7, evaluate local expansions
c       and all gradients directly
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,level,npts,nkids,ier)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
          do 6201 ibox=1,nboxes
             call d2tgetb(ier,ibox,box,center0,corners0,wlists)
             call d2tnkids(box,nkids)
             if (ifprint .ge. 2) then
                call prinf('ibox=*',ibox,1)
                call prinf('box=*',box,15)
                call prinf('nkids=*',nkids,1)
             endif
c
             if (nkids .eq. 0) then
                npts=box(10)
                if (ifprint .ge. 2) then
                   call prinf('npts=*',npts,1)
                   call prinf('isource=*',isource(box(9)),box(10))
                endif
             endif
             if (nkids .eq. 0) then
c       ... evaluate local expansions
                level=box(1)
                npts=box(10)
                if (level .ge. 2) then
                   if( box(10) .gt. 0 ) then

                      call bh2dtaevalall(scale(level),center0,
     1                rmlexp(iaddr(6,ibox)),rmlexp(iaddr(7,ibox)),
     2                rmlexp(iaddr(8,ibox)),rmlexp(iaddr(9,ibox)),
     3                rmlexp(iaddr(10,ibox)),nterms(level),
     4                sourcesort(1,box(9)),box(10),vel(box(9)),
     5                ifgrada,grada(box(9)),ifgradaa,gradaa(box(9)))
                   endif
                   if( box(12) .gt. 0 ) then
                      call bh2dtaevalall(scale(level),center0,
     1                rmlexp(iaddr(6,ibox)),rmlexp(iaddr(7,ibox)),
     2                rmlexp(iaddr(8,ibox)),rmlexp(iaddr(9,ibox)),
     3                rmlexp(iaddr(10,ibox)),nterms(level),
     4                targetsort(1,box(11)),box(12),veltarg(box(11)),
     5                ifgradatarg,gradatarg(box(11)),
     6                ifgradaatarg,gradaatarg(box(11)))
                   endif
                endif
             endif
 6201     continue
C$OMP END PARALLEL DO
          t2=second()
C$      t2=omp_get_wtime()
          timeinfo(7)=t2-t1
 8000     continue

          if( ifevalloc .eq. 0 ) goto 9000
             if(ifprint .ge. 1)
     $          call prinf('=== STEP 8 (direct) =====*',i,0)
             t1=second()
C$      t1=omp_get_wtime()
c
c       ... step 8, evaluate direct interactions
c
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(ibox,box,center0,corners0,nkids,list,nlist,npts)
C$OMP$PRIVATE(jbox,box1,center1,corners1)
C$OMP$PRIVATE(ier,ilist,itype)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
             do 6202 ibox=1,nboxes
                call d2tgetb(ier,ibox,box,center0,corners0,wlists)
                call d2tnkids(box,nkids)
                if (ifprint .ge. 2) then
                   call prinf('ibox=*',ibox,1)
                   call prinf('box=*',box,15)
                   call prinf('nkids=*',nkids,1)
                endif
                if (nkids .eq. 0) then
                   npts=box(10)
                   if (ifprint .ge. 2) then
                      call prinf('npts=*',npts,1)
                      call prinf('isource=*',isource(box(9)),box(10))
                   endif
                endif

                if (nkids .eq. 0) then
c       ... evaluate self interactions
                   call bhfmm2dpart_direct_self(box,sourcesort,
     $             ifcharge,chargesort,ifdipole,dip1sort,dip2sort,
     $             ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $             targetsort,ifveltarg,veltarg,ifgradatarg,
     $             gradatarg,ifgradaatarg,gradaatarg)
c       ... retrieve list #1
c       ... evaluate interactions with the nearest neighbours
c
                   itype=1
                   call d2tgetl(ier,ibox,itype,list,nlist,wlists)
                   if (ifprint.ge.2) call prinf('list1=*',list,nlist)
c
c       ... for all pairs in list #1,
c       evaluate the potentials and gradients directly
c
                   do 6203 ilist=1,nlist
                      jbox=list(ilist)
                      call d2tgetb(ier,jbox,box1,center1,corners1,
     $                wlists)
c
c       ... prune all sourceless boxes
c
                      if( box1(10) .eq. 0 ) goto 6203
                      call bhfmm2dpart_direct(box1,box,sourcesort,
     $                ifcharge,chargesort,ifdipole,dip1sort,dip2sort,
     $                ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $                targetsort,ifveltarg,veltarg,ifgradatarg,
     $                gradatarg,ifgradaatarg,gradaatarg)
 6203              continue
                endif
 6202        continue
C$OMP END PARALLEL DO
c
          t2=second()
C$      t2=omp_get_wtime()
          timeinfo(8)=t2-t1
 9000     continue
          if (ifprint .ge. 1) call prin2('timeinfo=*',timeinfo,8)
          d=0
          do i=1,8
             d=d+timeinfo(i)
          enddo
c
          if (ifprint .ge. 1) call prin2('sum(timeinfo)=*',d,1)
c
          if (ifprint .ge. 1) then
             call prinf('nboxes=*',nboxes,1)
             open(unit=25,file='output.dat',access='append')
             write(25,*) "nboxes=",nboxes
             close(25)
             call prinf('nsource=*',nsource,1)
             call prinf('ntarget=*',ntarget,1)
          endif

        return
        end
c
c
c
c
c
        subroutine bhfmm2dpart_direct_self(box,
     $     source,ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $     target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $     ifgradaatarg,gradaatarg)
        implicit real *8 (a-h,o-z)
c
        integer box(15),box1(15)
c
        real *8 source(2,*)
        complex *16 charge(*),dip1(*),dip2(*)
        real *8 target(2,*)
c
        complex *16 vel(*),grada(*),gradaa(*)
        complex *16 veltarg(*),gradatarg(*),gradaatarg(*)
        complex *16 vtemp,gatemp,gaatemp
c
c
        do 6160 j=box(9),box(9)+box(10)-1
        do 6150 i=box(9),box(9)+box(10)-1
            if (i .eq. j) goto 6150
            call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     1      ifdipole,dip1(i),dip2(i),source(1,j),vtemp,ifgrada,
     2      gatemp,ifgradaa,gaatemp)
            if (ifvel.eq. 1) vel(j)=vel(j)+vtemp
            if (ifgrada.eq. 1) then
               grada(j)=grada(j)+gatemp
            endif
            if (ifgradaa.eq. 1) then
               gradaa(j)=gradaa(j)+gaatemp
            endif
 6150   continue
 6160   continue
        do j=box(11),box(11)+box(12)-1
        do i=box(9),box(9)+box(10)-1
            call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     $      ifdipole,dip1(i),dip2(i),target(1,j),vtemp,
     1      ifgradatarg,gatemp,ifgradaatarg,gaatemp)
            if (ifveltarg .eq. 1) veltarg(j)=veltarg(j)+vtemp
            if (ifgradatarg .eq. 1) then
               gradatarg(j)=gradatarg(j)+gatemp
            endif
            if (ifgradaatarg .eq. 1) then
               gradaatarg(j)=gradaatarg(j)+gaatemp
            endif
        enddo
        enddo
c
        return
        end
c
c
c********************************************************************
        subroutine bhfmm2dpart_direct(box,box1,
     $     source,ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $     target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $     ifgradaatarg,gradaatarg)
        implicit real *8 (a-h,o-z)
c
        integer box(15),box1(15)
c
        real *8 source(2,*)
        complex *16 charge(*),dip1(*),dip2(*)
        real *8 target(2,*)
c
        complex *16 vel(*),grada(*),gradaa(*)
        complex *16 veltarg(*),gradatarg(*),gradaatarg(*)
        complex *16 vtemp,gatemp,gaatemp
c
c
        do j=box1(9),box1(9)+box1(10)-1
           call bh2ddireval(source(1,box(9)),box(10),ifcharge,
     1     charge(box(9)),ifdipole,dip1(box(9)),dip2(box(9)),
     2     source(1,j),vtemp,ifgrada,gatemp,ifgradaa,gaatemp)
           if (ifvel.eq. 1) vel(j)=vel(j)+vtemp
           if (ifgrada.eq. 1) then
             grada(j)=grada(j)+gatemp
           endif
           if (ifgradaa.eq. 1) then
             gradaa(j)=gradaa(j)+gaatemp
           endif
        enddo
c
        do j=box1(11),box1(11)+box1(12)-1
           call bh2ddireval(source(1,box(9)),box(10),ifcharge,
     1     charge(box(9)),ifdipole,dip1(box(9)),dip2(box(9)),
     2     target(1,j),vtemp,ifgradatarg,gatemp,ifgradaatarg,gaatemp)

           if (ifveltarg .eq. 1) veltarg(j)=veltarg(j)+vtemp
           if (ifgradatarg .eq. 1) then
             gradatarg(j)=gradatarg(j)+gatemp
           endif
           if (ifgradaatarg .eq. 1) then
             gradaatarg(j)=gradaatarg(j)+gaatemp
           endif
        enddo
c
        return
        end
c
c
c
c
c
        subroutine bh2dpartdirect(nsource,
     $     source,ifcharge,charge,ifdipole,dip1,dip2,
     $     ifvel,vel,ifgrada,grada,ifgradaa,gradaa,
     $     ntarget,target,ifveltarg,veltarg,ifgradatarg,gradatarg,
     $     ifgradaatarg,gradaatarg)
        implicit real *8 (a-h,o-z)
c
c       Generalized Cauchy interactions in R^2: evaluate all pairwise particle
c       interactions (ignoring self-interaction)
c       and interactions with targets via direct O(N^2) algorithm.
c
c       We use log(z) for the Green's function.
c       Self-interactions are not included.
c
c c2d: charge and dipstr are complex valued, z are complex numbers.
c
c        Note, that the complex valued logarithm is a multi-valued
c        function, so the potential values have to be interpreted
c        carefully, if charges are specified.  For example, only the
c        real part of potential is meaningful for real valued charges.
c        The gradients and hessians are valid for arbitrary complex charges.
c
c \phi(z_i) = \sum_{j\ne i} charge_j \log(z_i-z_j) + dipstr_j \frac{1}{z_i-z_j}
c
c        In this routine, we define the gradient as the first
c        derivative with respect to z, and the hessian as the second
c        derivative with respect to z.
c
c \gradient \phi(z_i) = \frac{\partial \phi(z_i)}{\partial z}
c \hessian  \phi(z_i) = \frac{\partial^2 \phi(z_i)}{\partial z^2}
c
c       INPUT PARAMETERS:
c
c       nsource: integer:  number of sources
c       source: real *8 (2,nsource):  source locations
c       ifcharge:  charge computation flag
c                  ifcharge = 1   =>  include charge contribution
c                                     otherwise do not
c       charge: complex *16 (nsource): charge strengths
c       ifdipole:  dipole computation flag
c                  ifdipole = 1   =>  include dipole contribution
c                                     otherwise do not
c       dipstr: complex *16 (nsource): dipole strengths
c
c       ifpot:  potential flag (1=compute potential, otherwise no)
c       ifgrad:  gradient flag (1=compute gradient, otherwise no)
c       ifhess:  hessian flag (1=compute hessian, otherwise no)
c       ntarget: integer:  number of targets
c       target: real *8 (2,ntarget):  target locations
c       ifpottarg:  target potential flag
c                   (1=compute potential, otherwise no)
c       ifgradtarg:  target gradient flag
c                   (1=compute gradient, otherwise no)
c       ihesstarg:  target hessian flag
c                   (1=compute hessian, otherwise no)
c
c       OUTPUT PARAMETERS:
c
c       pot: complex *16 (nsource): potential at source locations
c       grad: complex *16 (nsource): gradient  at source locations
c       hess: complex *16 (nsource): hessian at source locations
c       pottarg: complex *16 (ntarget): potential at target locations
c       gradtarg: complex *16 (ntarget): gradient  at target locations
c       hesstarg: complex *16 (ntarget): hessian at target locations
c
c
c
        real *8 source(2,*)
        complex *16 charge(*),dip1(*),dip2(*)
        real *8 target(2,*)
c
        complex *16 vel(*),grada(*),gradaa(*)
        complex *16 veltarg(*),gradatarg(*),gradaatarg(*)
        complex *16 vtemp,gatemp,gaatemp
c
c
        do i=1,nsource
        if( ifvel .eq. 1) vel(i)=0
        if( ifgrada.eq. 1) then
           grada(i)=0
        endif
        if( ifgradaa .eq. 1) then
           gradaa(i)=0
        endif
        enddo
c
        do i=1,ntarget
        if( ifveltarg .eq. 1) veltarg(i)=0
        if( ifgradatarg .eq. 1) then
           gradatarg(i)=0
        endif
        if( ifgradaatarg .eq. 1) then
           gradaatarg(i)=0
        endif
        enddo
c
        if( ifvel.eq.1 .or. ifgrada.eq.1 .or. ifgradaa.eq.1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,vtemp,gatemp,gaatemp)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do 6160 j=1,nsource
        do 6150 i=1,nsource
            if (i .eq. j) goto 6150
            call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     1      ifdipole,dip1(i),dip2(i),source(1,j),vtemp,ifgrada,
     2      gatemp,ifgradaa,gaatemp)
            if (ifvel.eq. 1) vel(j)=vel(j)+vtemp
            if (ifgrada.eq. 1) then
               grada(j)=grada(j)+gatemp
            endif
            if (ifgradaa.eq. 1) then
               gradaa(j)=gradaa(j)+gaatemp
            endif
 6150   continue
 6160   continue
C$OMP END PARALLEL DO
        endif
c
        if( ifveltarg .eq. 1 .or. ifgradatarg .eq. 1
     $      .or. ifgradaatarg .eq. 1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,vtemp,gatemp,gaatemp)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do j=1,ntarget
        do i=1,nsource
            call bh2ddireval(source(1,i),1,ifcharge,charge(i),
     1      ifdipole,dip1(i),dip2(i),target(1,j),vtemp,ifgradatarg,
     2      gatemp,ifgradaatarg,gaatemp)
            if (ifveltarg .eq. 1) veltarg(j)=veltarg(j)+vtemp
            if (ifgradatarg .eq. 1) then
               gradatarg(j)=gradatarg(j)+gatemp
            endif
            if (ifgradaatarg .eq. 1) then
               gradaatarg(j)=gradaatarg(j)+gaatemp
            endif
        enddo
        enddo
C$OMP END PARALLEL DO
        endif
c
        return
        end


      subroutine occultquad(z0,u1,u2,p,muo1,mu0,nz)
C  This routine computes the lightcurve for occultation
C  of a quadratically limb-darkened source without microlensing.
C  Please cite Mandel & Agol (2002) if you make use of this routine
C  in your research.  Please report errors or bugs to agol@tapir.caltech.edu
      implicit none
      integer i,nz
      double precision z0(nz),u1,u2,p,muo1(nz),mu0(nz),
     &       mu(nz),lambdad(nz),etad(nz),lambdae(nz),lam,
     &       pi,x1,x2,x3,z,omega,kap0,kap1,q,Kk,Ek,Pk,n,ellec,ellk,rj
      if(abs(p-0.5d0).lt.1.d-3) p=0.5d0
C
C Input:
C
C rs   radius of the source (set to unity)
C z0   impact parameter in units of rs
C p    occulting star size in units of rs
C u1   linear    limb-darkening coefficient (gamma_1 in paper)
C u2   quadratic limb-darkening coefficient (gamma_2 in paper)
C
C Output:
C
C muo1 fraction of flux at each z0 for a limb-darkened source
C mu0  fraction of flux at each z0 for a uniform source
C
C Limb darkening has the form:
C  I(r)=[1-u1*(1-sqrt(1-(r/rs)^2))-u2*(1-sqrt(1-(r/rs)^2))^2]/(1-u1/3-u2/6)/pi
C
C To use this routine
C
C Now, compute pure occultation curve:
      omega=1.d0-u1/3.d0-u2/6.d0
      pi=acos(-1.d0)
C Loop over each impact parameter:
      do i=1,nz
C substitute z=z0(i) to shorten expressions
        z=z0(i)
        x1=(p-z)**2
        x2=(p+z)**2
        x3=p**2-z**2
C the source is unocculted:
C Table 3, I.
        if(z.ge.1.d0+p) then
          lambdad(i)=0.d0
          etad(i)=0.d0
          lambdae(i)=0.d0
          goto 10
        endif
C the  source is completely occulted:
C Table 3, II.
        if(p.ge.1.d0.and.z.le.p-1.d0) then
          lambdad(i)=1.d0
          etad(i)=1.d0
          lambdae(i)=1.d0
          goto 10
        endif
C the source is partly occulted and the occulting object crosses the limb:
C Equation (26):
        if(z.ge.abs(1.d0-p).and.z.le.1.d0+p) then
          kap1=acos(min((1.d0-p*p+z*z)/2.d0/z,1.d0))
          kap0=acos(min((p*p+z*z-1.d0)/2.d0/p/z,1.d0))
          lambdae(i)=p*p*kap0+kap1
          lambdae(i)=(lambdae(i)-0.5d0*sqrt(max(4.d0*z*z-
     &               (1.d0+z*z-p*p)**2,0.d0)))/pi
        endif
C the occulting object transits the source star (but doesn't
C completely cover it):
        if(z.le.1.d0-p) lambdae(i)=p*p
C the edge of the occulting star lies at the origin- special
C expressions in this case:
        if(abs(z-p).lt.1.d-4*(z+p)) then
C Table 3, Case V.:
          if(z.ge.0.5d0) then
            lam=0.5d0*pi
            q=0.5d0/p
            Kk=ellk(q)
            Ek=ellec(q)
C Equation 34: lambda_3
            lambdad(i)=1.d0/3.d0+16.d0*p/9.d0/pi*(2.d0*p*p-1.d0)*Ek-
     &                 (32.d0*p**4-20.d0*p*p+3.d0)/9.d0/pi/p*Kk
C Equation 34: eta_1
            etad(i)=1.d0/2.d0/pi*(kap1+p*p*(p*p+2.d0*z*z)*kap0-
     &              (1.d0+5.d0*p*p+z*z)/4.d0*sqrt((1.d0-x1)*(x2-1.d0)))
            if(p.eq.0.5d0) then
C Case VIII: p=1/2, z=1/2
              lambdad(i)=1.d0/3.d0-4.d0/pi/9.d0
              etad(i)=3.d0/32.d0
            endif
            goto 10
          else
C Table 3, Case VI.:
            lam=0.5d0*pi
            q=2.d0*p
            Kk=ellk(q)
            Ek=ellec(q)
C Equation 34: lambda_4
            lambdad(i)=1.d0/3.d0+2.d0/9.d0/pi*(4.d0*(2.d0*p*p-1.d0)*Ek+
     &                 (1.d0-4.d0*p*p)*Kk)
C Equation 34: eta_2
            etad(i)=p*p/2.d0*(p*p+2.d0*z*z)
            goto 10
          endif
        endif
C the occulting star partly occults the source and crosses the limb:
C Table 3, Case III:
        if((z.gt.0.5d0+abs(p-0.5d0).and.z.lt.1.d0+p).or.(p.gt.0.5d0.
     &      and.z.gt.abs(1.d0-p)*1.0001d0.and.z.lt.p)) then
          lam=0.5d0*pi
          q=sqrt((1.d0-(p-z)**2)/4.d0/z/p)
          if(q.gt.1.0d0) q=0.99999d0
          Kk=ellk(q)
          Ek=ellec(q)
          n=1.d0/x1-1.d0
          Pk=Kk-n/3.d0*rj(0.d0,1.d0-q*q,1.d0,1.d0+n)
C Equation 34, lambda_1:
          lambdad(i)=1.d0/9.d0/pi/sqrt(p*z)*(((1.d0-x2)*(2.d0*x2+
     &        x1-3.d0)-3.d0*x3*(x2-2.d0))*Kk+4.d0*p*z*(z*z+
     &        7.d0*p*p-4.d0)*Ek-3.d0*x3/x1*Pk)
          if(z.lt.p) lambdad(i)=lambdad(i)+2.d0/3.d0
C Equation 34, eta_1:
          etad(i)=1.d0/2.d0/pi*(kap1+p*p*(p*p+2.d0*z*z)*kap0-
     &          (1.d0+5.d0*p*p+z*z)/4.d0*sqrt((1.d0-x1)*(x2-1.d0)))
          goto 10
        endif
C the occulting star transits the source:
C Table 3, Case IV.:
        if(p.le.1.d0.and.z.le.(1.d0-p)*1.0001d0) then
          lam=0.5d0*pi
          q=sqrt((x2-x1)/(1.d0-x1))
          if(q.gt.1.0d0) q=0.99999d0
          Kk=ellk(q)
          Ek=ellec(q)
          n=x2/x1-1.d0
          Pk=Kk-n/3.d0*rj(0.d0,1.d0-q*q,1.d0,1.d0+n)
C Equation 34, lambda_2:
          lambdad(i)=2.d0/9.d0/pi/sqrt(1.d0-x1)*((1.d0-5.d0*z*z+p*p+
     &         x3*x3)*Kk+(1.d0-x1)*(z*z+7.d0*p*p-4.d0)*Ek-3.d0*x3/x1*Pk)
          if(z.lt.p) lambdad(i)=lambdad(i)+2.d0/3.d0
          if(abs(p+z-1.d0).le.1.d-4) then
            lambdad(i)=2/3.d0/pi*acos(1.d0-2.d0*p)-4.d0/9.d0/pi*
     &            sqrt(p*(1.d0-p))*(3.d0+2.d0*p-8.d0*p*p)
          endif
C Equation 34, eta_2:
          etad(i)=p*p/2.d0*(p*p+2.d0*z*z)
        endif
 10     continue
C Now, using equation (33):
        muo1(i)=1.d0-((1.d0-u1-2.d0*u2)*lambdae(i)+(u1+2.d0*u2)*
     &      lambdad(i)+u2*etad(i))/omega
C Equation 25:
        mu0(i)=1.d0-lambdae(i)
      enddo
      return
      end

      FUNCTION rc(x,y)
      REAL*8 rc,x,y,ERRTOL,TINY,SQRTNY,BIG,TNBG,COMP1,COMP2,THIRD,C1,C2,
     *C3,C4
      PARAMETER (ERRTOL=.04d0,TINY=1.69d-38,SQRTNY=1.3d-19,BIG=3.d37,
     *TNBG=TINY*BIG,COMP1=2.236d0/SQRTNY,COMP2=TNBG*TNBG/25.d0,
     *THIRD=1.d0/3.d0,C1=.3d0,C2=1.d0/7.d0,C3=.375d0,C4=9.d0/22.d0)
      REAL*8 alamb,ave,s,w,xt,yt
      if(x.lt.0..or.y.eq.0..or.(x+abs(y)).lt.TINY.or.(x+
     *abs(y)).gt.BIG.or.(y.lt.-COMP1.and.x.gt.0..and.x.lt.COMP2))then
        write(0,*) 'invalid arguments in rc'
        rc=0.0
        return
      endif
c      pause
c     *'invalid arguments in rc'
      if(y.gt.0.d0)then
        xt=x
        yt=y
        w=1.
      else
        xt=x-y
        yt=-y
        w=sqrt(x)/sqrt(xt)
      endif
1     continue
        alamb=2.d0*sqrt(xt)*sqrt(yt)+yt
        xt=.25d0*(xt+alamb)
        yt=.25d0*(yt+alamb)
        ave=THIRD*(xt+yt+yt)
        s=(yt-ave)/ave
      if(abs(s).gt.ERRTOL)goto 1
      rc=w*(1.d0+s*s*(C1+s*(C2+s*(C3+s*C4))))/sqrt(ave)
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software

      FUNCTION rj(x,y,z,p)
      REAL*8 rj,p,x,y,z,ERRTOL,TINY,BIG,C1,C2,C3,C4,C5,C6,C7,C8
      PARAMETER (ERRTOL=.05d0,TINY=2.5d-13,BIG=9.d11,C1=3.d0/14.d0,
     *C2=1.d0/3.d0,C3=3.d0/22.d0,C4=3.d0/26.d0,C5=.75d0*C3,
     *C6=1.5d0*C4,C7=.5d0*C2,C8=C3+C3)
CU    USES rc,rf
      REAL*8 a,alamb,alpha,ave,b,beta,delp,delx,dely,delz,ea,eb,ec,ed,
     *ee,fac,pt,rcx,rho,sqrtx,sqrty,sqrtz,sum,tau,xt,yt,zt,rc,rf
      if(min(x,y,z).lt.0..or.min(x+y,x+z,y+z,abs(p)).lt.TINY.or.max(x,y,
     *z,abs(p)).gt.BIG)then
         write(0,*) x,y,z,abs(p)
         write(0,*) 'invalid arguments in rj'
         rj=0.0
         return
      endif
      sum=0.d0
      fac=1.d0
      if(p.gt.0.d0)then
        xt=x
        yt=y
        zt=z
        pt=p
      else
        xt=min(x,y,z)
        zt=max(x,y,z)
        yt=x+y+z-xt-zt
        a=1.d0/(yt-p)
        b=a*(zt-yt)*(yt-xt)
        pt=yt+b
        rho=xt*zt/yt
        tau=p*pt/yt
        rcx=rc(rho,tau)
      endif
1     continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        alpha=(pt*(sqrtx+sqrty+sqrtz)+sqrtx*sqrty*sqrtz)**2
        beta=pt*(pt+alamb)**2
        sum=sum+fac*rc(alpha,beta)
        fac=.25d0*fac
        xt=.25d0*(xt+alamb)
        yt=.25d0*(yt+alamb)
        zt=.25d0*(zt+alamb)
        pt=.25d0*(pt+alamb)
        ave=.2d0*(xt+yt+zt+pt+pt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
        delp=(ave-pt)/ave
      if(max(abs(delx),abs(dely),abs(delz),abs(delp)).gt.ERRTOL)goto 1
      ea=delx*(dely+delz)+dely*delz
      eb=delx*dely*delz
      ec=delp**2
      ed=ea-3.d0*ec
      ee=eb+2.d0*delp*(ea-ec)
      rj=3.d0*sum+fac*(1.d0+ed*(-C1+C5*ed-C6*ee)+eb*(C7+delp*
     *(-C8+delp*C4))+delp*ea*(C2-delp*C3)-C2*delp*ec)/(ave*sqrt(ave))
      if (p.le.0.d0) rj=a*(b*rj+3.d0*(rcx-rf(xt,yt,zt)))
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software

      function ellec(k)
      implicit none
      double precision k,m1,a1,a2,a3,a4,b1,b2,b3,b4,ee1,ee2,ellec
C Computes polynomial approximation for the complete elliptic
C integral of the second kind (Hasting's approximation):
      m1=1.d0-k*k
      a1=0.44325141463d0
      a2=0.06260601220d0
      a3=0.04757383546d0
      a4=0.01736506451d0
      b1=0.24998368310d0
      b2=0.09200180037d0
      b3=0.04069697526d0
      b4=0.00526449639d0
      ee1=1.d0+m1*(a1+m1*(a2+m1*(a3+m1*a4)))
      ee2=m1*(b1+m1*(b2+m1*(b3+m1*b4)))*log(1.d0/m1)
      ellec=ee1+ee2
      return
      end

      function ellk(k)
      implicit none
      double precision a0,a1,a2,a3,a4,b0,b1,b2,b3,b4,ellk,
     &       ek1,ek2,k,m1
C Computes polynomial approximation for the complete elliptic
C integral of the first kind (Hasting's approximation):
      m1=1.d0-k*k
      a0=1.38629436112d0
      a1=0.09666344259d0
      a2=0.03590092383d0
      a3=0.03742563713d0
      a4=0.01451196212d0
      b0=0.5d0
      b1=0.12498593597d0
      b2=0.06880248576d0
      b3=0.03328355346d0
      b4=0.00441787012d0
      ek1=a0+m1*(a1+m1*(a2+m1*(a3+m1*a4)))
      ek2=(b0+m1*(b1+m1*(b2+m1*(b3+m1*b4))))*log(m1)
      ellk=ek1-ek2
      return
      end

      FUNCTION rf(x,y,z)
      REAL*8 rf,x,y,z,ERRTOL,TINY,BIG,THIRD,C1,C2,C3,C4
      PARAMETER (ERRTOL=.08d0,TINY=1.5d-38,BIG=3.d37,THIRD=1.d0/3.d0,
     *C1=1.d0/24.d0,C2=.1d0,C3=3.d0/44.d0,C4=1.d0/14.d0)
      REAL*8 alamb,ave,delx,dely,delz,e2,e3,sqrtx,sqrty,sqrtz,xt,yt,zt
      if(min(x,y,z).lt.0.d0.or.min(x+y,x+z,y+z).lt.TINY.or.max(x,y,
     *z).gt.BIG)then
        write(0,*) 'invalid arguments in rf'
        rf=0.0
      endif
      xt=x
      yt=y
      zt=z
1     continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        xt=.25d0*(xt+alamb)
        yt=.25d0*(yt+alamb)
        zt=.25d0*(zt+alamb)
        ave=THIRD*(xt+yt+zt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
      if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)goto 1
      e2=delx*dely-delz**2
      e3=delx*dely*delz
      rf=(1.d0+(C1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(ave)
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 0NL&WR2.


SUBROUTINE ENVCN2
!======================================
! Environmental CNi Fermi
!======================================
! Calculates the CNi for a cluster interacting with an implicit environment.
! Uses the Fermi formulation of the CNi.
! To use the polynomial CNi, change to the ENVCN subroutine.
!======================================
 USE PARACLUSTER
 USE CLUSTER
 USE POTENTIAL
 USE ENFORCE
 USE DISTANCE
 USE ENVIRONMENT

  IMPLICIT NONE

  integer               :: i, j
  double precision      :: gamma_env
  REAL(8), DIMENSION(nsiz,nsiz)   :: dij, df_dx, df_dy, df_dz

 !write(203,*) ipas, beta_env_angstrom, rc_env, beta_env

   DO i = 1, natom
      DO j = 1, natom
         dij(j,i) = (beta_env * pair_dist(j,i) ) - alpha_env
         !write(202,*) ipas, pair_dist(j,i), dij(j,i)
      END DO
   END DO

   ! Elements on the diagonal
   DO i = 1, natom
      env_s(i,i) = 0.d0
   END DO

   DO i = 1, natom-1
      DO j = i+1, natom
            if (abs(dij(j,i)) .le. 16.d0) then
            !write(185,*) ipas, i, j, dij(j,i)
            gamma_env = exp(dij(j,i))
            env_s(j,i) = 1.d0/(1.d0 + gamma_env)
            env_s(i,j) = env_s(j,i)
            env_ds(j,i) = -beta_env_angstrom * gamma_env / (gamma_env+1)**2
            env_ds(i,j) = env_ds(j,i)
            else

            gamma_env  = 10000
            env_s(j,i) = 0.d0
            env_s(i,j) = env_s(j,i)
            env_ds(j,i) = 0.d0
            env_ds(i,j) = env_ds(j,i)
            end if

!      write(183,*) ipas, i, j, dij(j,i), gamma_env, env_s(j,i)

      END DO ! on j
   END DO ! on i

   DO i = 1, natom
      env_cn(i) = SUM(env_s(1:natom,i))
      !WRITE(184,*) ipas, i, env_cn(i)
      IF (env_cn(i) .le. 5.d0) THEN
         env_cn(i) = 5.d0
      END IF
      IF (env_cn(i) .gt. 12.d0) THEN
         env_cn(i) = 12.d0
      END IF
   END DO

   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            env_comfactor  = env_dS(j,i)/ pair_dist(j,i)
            df_dx(j,i) = env_comfactor * xyz_dist(1,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dy(j,i) = env_comfactor * xyz_dist(2,j,i) ! order of indexes depends on the definition of xyz_dist
            df_dz(j,i) = env_comfactor * xyz_dist(3,j,i) ! order of indexes depends on the definition of xyz_dist
         ELSE
            df_dx(j,i) = 0.d0
            df_dy(j,i) = 0.d0
            df_dz(j,i) = 0.d0
         END IF
      END DO
   END DO

   DO i = 1, natom
      ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
      env_dcn_dx(i) = SUM(df_dx(1:natom, i))
      env_dcn_dy(i) = SUM(df_dy(1:natom, i))
      env_dcn_dz(i) = SUM(df_dz(1:natom, i))
!      write(204,*) ipas, i, env_dcn_dx(i), env_dcn_dy(i), env_dcn_dz(i)
   END DO

END SUBROUTINE ENVCN2


      REAL*8 FUNCTION RPMIN(M1,M2,VSTAR,H,PERI)
*
*       Minimum pericentre distance for energy change (H < 0).
*       ------------------------------------------------------
*
      IMPLICIT REAL*8 (A-H,M,O-Z)
      DATA FUDGE /1.0D-02/
*
*       Adopt simplified eccentricity factor valid for ECC = 1.
      GE = 425.0*3.1415/(32.0*SQRT(2.0D0))
      CLIGHT = 3.0D+05/VSTAR
      FAC = (1.0/CLIGHT)**3.5
*
*       Set mass expression for energy change in N-body units.
      FM = SQRT(M1 + M2)*M1**2*M2**2
*       Form scaled energy (without r_min).
      DE = 8.0/15.0*FAC*FM*CLIGHT**2*GE
*
*       Adopt a fraction of the energy (-MU*H) for determination of RPMIN.
      MU = M1*M2/(M1 + M2)
      DEMAX = -FUDGE*MU*H
      RPMIN = (DE/DEMAX)**(2.0/7.0)
*
*       Include some diagnostics (suppressed).
*     SEMI = -(M1 + M2)/H
*     WRITE (6,5)  SEMI, RPMIN, PERI
*   5 FORMAT (' RPMIN    A RPM PERI ',1P,3E10.2)
*
      RETURN
      END


PROGRAM xspear
!C     driver for routine spear
INTEGER NDAT,NMON
PARAMETER(NDAT=20,NMON=12)
INTEGER i,j
REAL*8 d,probd,probrs,rs,zd
REAL*8 data1(NDAT),data2(NDAT),rays(NDAT,NMON)
REAL*8 wksp1(NDAT),wksp2(NDAT),ave(NDAT),zlat(NDAT)
CHARACTER city(NDAT)*15,mon(NMON)*4,text*64
open(7,file='/Users/dingding 1/Desktop/spear/TABLE2.DAT',status='OLD')
read(7,*)
read(7,'(a)') text
read(7,'(15x,12a4/)') (mon(i),i=1,12)
do i=1,NDAT
  read(7,'(a15,12f4.0,f6.0,f6.1)')&
&     city(i),(rays(i,j),j=1,12),ave(i),zlat(i)
enddo
close(7)
write(*,*) text
write(*,'(1x,15x,12a4)') (mon(i),i=1,12)
do i=1,NDAT
  write(*,'(1x,a,12i4,i6,f6.1)') city(i),&
&       (nint(rays(i,j)),j=1,12)
enddo
!C     check temperature correlations between different months
write(*,'(/1x,a)')&
&     'Are sunny summer places also sunny winter places?'
write(*,'(1x,2a)') 'Check correlation of sampled U.S. solar ',&
&     'radiation (july with other months)'
write(*,'(/1x,a,t16,a,t23,a,t37,a,t49,a,t63,a/)')&
&     'Month','D','St. Dev.','PROBD',&
&    'Spearman R','PROBRS'
do 13 i=1,NDAT
  data1(i)=rays(i,1)
13    continue
do 15 j=1,12
  do 14 i=1,NDAT
    data2(i)=rays(i,j)
14      continue
  call spear(data1,data2,NDAT,wksp1,wksp2,d,zd,probd,rs,probrs)
  write(*,'(1x,a,f13.2,2f12.6,3x,2f12.6)')&
&       mon(j),d,zd,probd,rs,probrs
15    continue
END

include 'betacf.f90'
include 'betai.f90'
include 'crank.f90'
include 'erfcc.f90'
include 'gammln.f90'
include 'sort2.f90'
include 'spear.f90'


c-----------------------------------------------------------------------
c
c Header with common subroutine
c
      include 't310-basis-f.h'
c-----------------------------------------------------------------------
      subroutine feval(x1,x2,val)
      real*8 x1,x2,val

      val=x1*x1+x2*x2+x1*x2+1

      end
c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer input,output,weights
      integer p,q,d
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)
      real*8 xr(d*p)
      real*8 iinput(p)
      real*8 ooutput(q)
      real*8 wweights(q)
      real*8 val,diff
      real*8 x1,x2
      integer*8 offset1,offset2

      integer b

      character arg*32

      xr=(/0.0d0,5.0d-1,1.0d0,0.0d0,5.0d-1,0.0d0,0.0d0,0.0d0,
     $     0.0d0,5.0d-1,5.0d-1,1.0d0/)

      call getarg(1,arg)

      call buildmats(qref,qweight,interp,grad)

      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,
     $  interp,grad,qref,qweight,b,err)

      do i=1,p
        x1=xr(0*p+i)
        x2=xr(1*p+i)
        call feval(x1,x2,val)
        iinput(i)=val
      enddo

      call ceedvectorcreate(ceed,p,input,err)
      call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,
     $  iinput,err)
      call ceedvectorcreate(ceed,q,output,err)
      call ceedvectorsetvalue(output,0.d0,err)
      call ceedvectorcreate(ceed,q,weights,err)
      call ceedvectorsetvalue(weights,0.d0,err)

      call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_interp,
     $  input,output,err)
      call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_weight,
     $  ceed_null,weights,err)

      call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,
     $  offset1,err)
      call ceedvectorgetarrayread(weights,ceed_mem_host,wweights,
     $  offset2,err)
      val=0
      do i=1,q
        val=val+ooutput(i+offset1)*wweights(i+offset2)
      enddo
      call ceedvectorrestorearrayread(output,ooutput,offset1,err)
      call ceedvectorrestorearrayread(weights,wweights,offset2,err)

      diff=val-17.d0/24.d0
      if (abs(diff)>1.0d-10) then
        write(*,'(A,I1,A,F12.8,A,F12.8)')
     $  '[',i,'] ',val,' != ',17.d0/24.d0
      endif

      call ceedvectordestroy(input,err)
      call ceedvectordestroy(output,err)
      call ceedvectordestroy(weights,err)
      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
c-----------------------------------------------------------------------


program atest
   use mytype
   use qsort_c_module
   implicit none
   integer :: numnz,msize
   integer :: k
   integer , parameter :: maxnz=100000
   integer , allocatable:: row_ptr(:)
   type(ent), allocatable:: vals(:)
! Read the number of nonzeros and the size of the matrix
   read(*,*)numnz,msize
! Allocate our vector to store the data triplets.  In
! the end this will also contain col_ind and values
! in the proper order.
! NOTE: numnz <= maxnz
   allocate(vals(maxnz))
! Read our data.  In a real program the data could be
! generated on the fly in any order.
   do k=1,numnz
        read(*,*)vals(k)%i,vals(k)%j,vals(k)%val
   enddo
! On return from QsortC vals%j contains the col_ind
! and vals%val contains the values.  Note we pass in
! only the section of the array that contains data.
   call QsortC(vals(1:numnz))
! By convention row_ptr is one bigger than the
! size of the matrix and the last entry is equal
! to numnz+1.
   allocate(row_ptr(msize+1))
! Fill row_ptr
   call getrow(vals,row_ptr,numnz)
! Write out the row_ptr
   write(*,*)row_ptr
   write(*,*)
! Write out the col_ind
   write(*,*)vals(1:numnz)%j
   write(*,*)
! Write out the values
   write(*,*)vals(1:numnz)%val
 end program


      real             function SRANU()
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SRANU Krogh  Changes to use M77CON
c>> 1994-06-24 SRANU CLL Changed common to use RANC[D/S]1 & RANC[D/S]2.
c>> 1992-03-16 CLL
c>> 1991-11-26 CLL Reorganized common. Using RANCM[A/D/S].
c>> 1991-11-22 CLL Added call to RAN0, and SGFLAG in common.
c>> 1991-01-15 CLL Reordered common contents for efficiency.
C>> 1990-01-23 CLL  Making names in common same in all subprogams.
C>> 1987-04-22 SRANU  Lawson  Initial code.
c        Returns one pseudorandom number from the uniform distribution
c        on [0., 1.].
c     C. L. Lawson & S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
c--S replaces "?": ?RANU, ?RANUA, RANC?1, RANC?2, ?PTR, ?NUMS, ?GFLAG
C     RANCS1 and RANCS2 are common blocks.
c     Calls RAN0 to initialize SPTR and SGFLAG.
c     ------------------------------------------------------------------
      integer M
      parameter(M = 97)
      real             SNUMS(M)
      common/RANCS2/SNUMS
c
      integer SPTR
      logical SGFLAG
      common/RANCS1/SPTR, SGFLAG
      save  /RANCS1/, /RANCS2/, FIRST
      logical FIRST
      data    FIRST / .true. /
c     ------------------------------------------------------------------
      if(FIRST) then
         FIRST = .false.
         call RAN0
      endif
c
      SPTR = SPTR - 1
      if(SPTR .eq. 0) then
         call SRANUA(SNUMS, M)
         SPTR = M
      endif
      SRANU = SNUMS(SPTR)
      return
      end


!-------------------------------------------------------------------
! class-hpc-smoke-ring: A simple sample field solver.
!
!    by Akira Kageyama, Kobe University, Japan.
!       email: sgks@mac.com
!
!    Copyright 2018 Akira Kageyama
!
!    This software is released under the MIT License.
!
!-------------------------------------------------------------------
!    src/slicedata.f90
!-------------------------------------------------------------------

module slicedata_m
  use ut_m
  use field_m
  use params_m
  use debug_m
  use solver_m
  implicit none
  private
  public :: slicedata__initialize,  &
            slicedata__write

  ! - 2-D single precision real arrays.
  real(SR), dimension(:,:), allocatable :: Slice_vx  ! x-comp. of velocity
  real(SR), dimension(:,:), allocatable :: Slice_vy  ! y-comp.
  real(SR), dimension(:,:), allocatable :: Slice_vz  ! z-comp.
  real(SR), dimension(:,:), allocatable :: Slice_ps  ! Pressure
  real(SR), dimension(:,:), allocatable :: Slice_en  ! Enstrophy

  logical, save :: Initialize_done = .false.
  integer(SI), parameter :: FILE_SLICEDATA = 20

contains

  subroutine make_single_precision_field(vel,ps)
    type(field__vector3d_t),       intent(in) :: vel
    real(DR), dimension(NX,NY,NZ), intent(in) :: ps

    integer(SI) :: slice_j = NY / 2

    type(field__vector3d_t)       :: vor   ! vorticity
    real(DR), dimension(NX,NY,NZ) :: enstrophy

!>        vor = .curl.vel
!>  enstrophy = vor.dot.vor
          vor = operator_curl(vel)
    enstrophy = operator_dot_product(vor,vor)

    Slice_vx = real(    vel%x(:,slice_j,:),SR)
    Slice_vy = real(    vel%y(:,slice_j,:),SR)
    Slice_vz = real(    vel%z(:,slice_j,:),SR)
    Slice_ps = real(       ps(:,slice_j,:),SR)
    Slice_en = real(enstrophy(:,slice_j,:),SR)

    call debug__print('called slicedata/make_single_precision_field.')
  end subroutine make_single_precision_field

!
! Private
!===============
! Public
!

  subroutine slicedata__initialize
    allocate(Slice_vx(NX,NZ),   &
             Slice_vy(NX,NZ),   &
             Slice_vz(NX,NZ),   &
             Slice_ps(NX,NZ),   &
             Slice_en(NX,NZ))

    call debug__print('Slice data allocated.')

    open(FILE_SLICEDATA,                                &
         file=trim(params__get_string('Slicedata_tag')),  &
         form='unformatted')

    Initialize_done = .true.

    call debug__print('called slicedata__initlilize')
  end subroutine slicedata__initialize

  subroutine slicedata__write(nloop,time,fluid)
    integer(DI),          intent(in) :: nloop
    real(DR),             intent(in) :: time
    type(field__fluid_t), intent(in) :: fluid

    type(field__vector3d_t) :: vel

    if ( params__get_integer('Slicedata_nskip') <= 0 ) return
                                      ! Set zero or negative integer
                                      ! when you don't want to
                                      ! save any slice data.

    if ( mod(nloop,params__get_integer('Slicedata_nskip')) /= 0 ) return

    call ut__assert(Initialize_done,"<slicedata__write> Forgot init?")

    call solver__get_subfield(fluid,vel)

    call make_single_precision_field(vel,fluid%pressure)

    write(FILE_SLICEDATA) nloop, real(time,SR),  &
                          Slice_vx, Slice_vy, Slice_vz,  &
                          Slice_ps, Slice_en

    call ut__message('#slice data saved at ', nloop, time)
    call debug__print('called slicedata__write.')
  end subroutine slicedata__write

end module slicedata_m


subroutine tencrossval
use fdeclarations

implicit none

write(*,*) ' '
write(*,*) 'Initializing fuzzy Bayesian inference...'
call sleep(2)
call randomizer
do zz=1,10
write(*,*) ' '
write(*,*) 'ITERATION', zz
write(*,*) '----------------------'
call sleep(2)
call iterator10

write(*,*) 'Developing rules database...'
call classifier

open(49, file='log.txt', action='write', status='replace')
write(49,*) ' Classification matrix'
write(49,*) ' V      D      S      T      HS'
do i=1,ii
write(49,10) (cmatrix(i,j), j=1,w)
end do

!write(49,*) ' '
!write(49,*) 'rmatrix'
!do i=1,e
!write(49,10) (rmatrix(i,j), j=1,w-1)
!end do

call combinations

open (unit=59, file='amatrix.txt', status='old', action='read')
read (59,*) nn

allocate(amatrix(nn,w-1))

do i=1,nn
read(59,*) (amatrix(i,j), j=1,w-1)
end do

call ruler

!write(49,*) ' '
!write(49,*) 'p1matrix'
!do i=1,nn
!write(49,10) (p1matrix(i,j), j=1,w+1)
!end do

write(49,*) ' '
write(49,*) ' Bayesian joint probabilities matrix'
write(49,*) ' H      G      M      P      B'
do i=1,nn
write(49,10) (p2matrix(i,j), j=1,w)
end do

write(*,*) 'Development of rules successful!'
write(*,*) ' '
call sleep(2)

write(*,*) 'Fuzzifying inputs...'
call fuzzifier
!write(49,*) ' '
!write(49,*) 'V Fuzzification'
!do i=1,n
!write(49,10) (uf(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'D Fuzzification'
!do i=1,n
!write(49,10) (df(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'S Classes'
!do i=1,n
!write(49,10) (sf(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'T Fuzzification'
!do i=1,n
!write(49,10) (tf(i,j), j=1,e)
!end do
write(*,*) 'Fuzzification successful!'
write(*,*) ' '

write(*,*) 'Applying Bayesian joint probability rules...'
write(*,*) ' '
call sleep(2)
allocate(bmatrix(e**(w-1),w-1,z))
allocate(bayh(nn,z))
allocate(bayg(nn,z))
allocate(baym(nn,z))
allocate(bayp(nn,z))
allocate(bayb(nn,z))
allocate(fmatrix(nn,w-1,z))

do i=1,z
open(29, file='bmatrix.txt', action='write', status='replace')
write(29,*) nn
call permutator
close(29, status='keep')

open (unit=39, file='bmatrix.txt', status='old', action='read')
read (39,*) nn
do jj=1,nn
read(39,*) (fmatrix(jj,j,i), j=1,w-1)
end do
close(39, status='keep')
do j=1,nn
bayh(j,i)=product(fmatrix(j,:,i))*p2matrix(j,1)
bayg(j,i)=product(fmatrix(j,:,i))*p2matrix(j,2)
baym(j,i)=product(fmatrix(j,:,i))*p2matrix(j,3)
bayp(j,i)=product(fmatrix(j,:,i))*p2matrix(j,4)
bayb(j,i)=product(fmatrix(j,:,i))*p2matrix(j,5)
end do
write(*,*) 'Rules application for observation', i, 'successful'
end do
write(*,*) ' '
write(*,*) 'Rules application successful!'
write(*,*) ' '
write(*,*) 'Calculating Bayesian joint probabilities...'
call sleep(2)
!write(49,*) ' '
!write(49,*) 'fmatrix'
!do i=1,nn
!write(49,10) (fmatrix(i,j,jj), j=1,w-1)
!end do
write(*,*) 'Joint probability calculation successful!'
write(*,*) ' '
print *, 'Calculating response variable...'
call sleep(2)
write(*,*) ' '
do i=1,z
write(*,*) 'Response variable calculation for observation', i, 'successful'
bayg1(i)=sum(bayg(1:nn,i))
baym1(i)=sum(baym(1:nn,i))
bayh1(i)=sum(bayh(1:nn,i))
bayp1(i)=sum(bayp(1:nn,i))
bayb1(i)=sum(bayb(1:nn,i))
end do
write(*,*) ' '
write(*,*) 'Response variable calculation successful!'

call rules2
!write(49,*) ' '
!write(49,*) 'bayH1'
!do i=1,n
!write(49,10) (bayh1(i))
!end do

!write(49,*) ' '
!write(49,*) 'bayb'
!do i=1,nn
!write(49,10) (bayb(i,j), j=1,n)
!end do

write (49,*) ' '
write (49,*) ' Joint probability of High suitability class'
do i=1,z
write(49,10) (bayh2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Good suitability class'
do i=1,z
write(49,10) (bayg2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Moderate suitability class'
do i=1,z
write(49,10) (baym2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Poor suitability class'
do i=1,z
write(49,10) (bayp2(i))
end do

write (49,*) ' '
write (49,*) ' Joint probability of Bad suitability class'
do i=1,z
write(49,10) (bayb2(i))
end do

do i=1,z
hs(i)=bhigh(i)+bgood(i)+bmoderate(i)+bpoor(i)+bbad(i)
if (bayg1(i)<=0 .and. bayh1(i)<=0 .and. baym1(i)<=0 .and. bayp1(i)<=0 .and. bayb1(i)<=0) then
suitability(i,zz)=suitability(i-1,zz)
else
suitability(i,zz)=hs(i)
end if

end do

!open(19, file='suitability.txt', action='write', status='replace')
!do i=1,z
!write(*,10) (suitability(i,zz))
!end do
!read(*,*)
deallocate(dmatrix)
deallocate(ematrix)
deallocate(amatrix)
deallocate(p1matrix)
deallocate(p2matrix)
deallocate(uf)
deallocate(df)
deallocate(tf)
deallocate(sf)
deallocate(bmatrix)
deallocate(fmatrix)
deallocate(bayh)
deallocate(bayg)
deallocate(baym)
deallocate(bayp)
deallocate(bayb)

close(49, status='keep')
close(59, status='keep')
!close(19, status='keep')
call performance

write(*,44) ' Performance - CCI  ', icci(zz)*100, ' %'

end do
write(*,*) ' '
write(*,*) 'End of cross-validation process!'
write(*,*) ' '
44 format (a,f6.2,a)
10 format (10f7.3)
end subroutine tencrossval


      subroutine sva (a,mda,m,n,mdata,b,sing,names,iscale,d)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c               singular value analysis printout
c
c     iscale       set by user to 1, 2, or 3 to select column scaling
c                  option.
c                  1   subr will use identity scaling and ignore the d()
c                      array.
c                  2   subr will scale nonzero cols to have unit euclide
c                      length and will store reciprocal lengths of
c                      original nonzero cols in d().
c                  3   user supplies col scale factors in d(). subr
c                      will mult col j by d(j) and remove the scaling
c                      from the soln at the end.
c
      dimension  a(mda,n), b(m), sing(01),d(n)
c     sing(3*n)
      dimension names(n)
      logical test
      double precision   sb, dzero
      dzero=0.d0
      one=1.
      zero=0.
      if (m.le.0 .or. n.le.0) return
      np1=n+1
      write (6,270)
      write (6,260) m,n,mdata
      go to (60,10,10), iscale
c
c     apply column scaling to a
c
   10      do 50 j=1,n
           a1=d(j)
           go to (20,20,40), iscale
   20      sb=dzero
                do 30 i=1,m
   30           sb=sb+dble(a(i,j))**2
           a1=dsqrt(sb)
           if (a1.eq.zero) a1=one
           a1=one/a1
           d(j)=a1
   40           do 50 i=1,m
   50           a(i,j)=a(i,j)*a1
      write (6,280) iscale,(d(j),j=1,n)
      go to 70
   60 continue
      write (6,290)
   70 continue
c
c     obtain  sing. value decomp. of scaled matrix.
c
c**********************************************************
      call svdrs (a,mda,m,n,b,1,1,sing,ier)
      if (ier.eq.0) goto 75
         write (6,295)
         return
   75 continue
c**********************************************************
c
c     print the v matrix.
c
      call mfeout (a,mda,n,n,names,1)
      if (iscale.eq.1) go to 90
c
c     replace v by d*v in the array a()
c
           do 80 i=1,n
                do 80 j=1,n
   80           a(i,j)=d(i)*a(i,j)
c
c     g  now in  b array.  v now in a array.
c
c
c     obtain summary output.
c
   90 continue
      write (6,220)
c
c     compute cumulative sums of squares of components of
c     g and store them in sing(i), i=minmn+1,...,2*minmn+1
c
      sb=dzero
      minmn=min0(m,n)
      minmn1=minmn+1
      if (m.eq.minmn) go to 110
           do 100 i=minmn1,m
  100      sb=sb+dble(b(i))**2
  110 sing(2*minmn+1)=sb
           do 120 jj=1,minmn
           j=minmn+1-jj
           sb=sb+dble(b(j))**2
           js=minmn+j
  120      sing(js)=sb
      a3=sing(minmn+1)
      a4=sqrt(a3/float(max0(1,mdata)))
      write (6,230) a3,a4
c
      nsol=0
c
c
c
           do 160 k=1,minmn
           if (sing(k).eq.zero) go to 130
           nsol=k
           pi=b(k)/sing(k)
           a1=one/sing(k)
           a2=b(k)**2
           a3=sing(minmn1+k)
           a4=sqrt(a3/float(max0(1,mdata-k)))
           test=sing(k).ge.100..or.sing(k).lt..001
           if (test) write (6,240) k,sing(k),pi,a1,b(k),a2,a3,a4
           if (.not.test) write (6,250) k,sing(k),pi,a1,b(k),a2,a3,a4
           go to 140
  130      write (6,240) k,sing(k)
           pi=zero
  140           do 150 i=1,n
                a(i,k)=a(i,k)*pi
  150           if (k.gt.1) a(i,k)=a(i,k)+a(i,k-1)
  160      continue
c
c     compute and print values of ynorm and rnorm.
c
      write (6,300)
      j=0
      ysq=zero
      go to 180
  170 j=j+1
      ysq=ysq+(b(j)/sing(j))**2
  180 ynorm=sqrt(ysq)
      js=minmn1+j
      rnorm=sqrt(sing(js))
      yl=-1000.
      if (ynorm.gt.0.) yl=alog10(ynorm)
      rl=-1000.
      if (rnorm.gt.0.) rl=alog10(rnorm)
      write (6,310) j,ynorm,rnorm,yl,rl
      if (j.lt.nsol) go to 170
c
c     compute values of xnorm and rnorm for a sequence of values of
c     the levenberg-marquardt parameter.
c
      if (sing(1).eq.zero) go to 210
      el=alog10(sing(1))+one
      el2=alog10(sing(nsol))-one
      del=(el2-el)/20.
      ten=10.
      aln10=alog(ten)
      write (6,320)
           do 200 ie=1,21
c     compute        alamb=10.**el
           alamb=exp(aln10*el)
           ys=0.
           js=minmn1+nsol
           rs=sing(js)
                do 190 i=1,minmn
                sl=sing(i)**2+alamb**2
                ys=ys+(b(i)*sing(i)/sl)**2
                rs=rs+(b(i)*(alamb**2)/sl)**2
  190           continue
           ynorm=sqrt(ys)
           rnorm=sqrt(rs)
           rl=-1000.
           if (rnorm.gt.zero) rl=alog10(rnorm)
           yl=-1000.
           if (ynorm.gt.zero) yl=alog10(ynorm)
           write (6,330) alamb,ynorm,rnorm,el,yl,rl
           el=el+del
  200      continue
c
c     print candidate solutions.
c
  210 if (nsol.ge.1) call mfeout (a,mda,n,nsol,names,2)
      return
  220 format (42h0 index  sing. value       p coef         ,48hrecip. s.
     1v.             g coef            g**2  ,
     234h            c.s.s.    n.s.r.c.s.s.)
  230 format (1h ,5x,1h0,88x,1pe15.4,1pe17.4)
  240 format (1h ,i6,e12.4,1p,(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4
     1,2x,e15.4))
  250 format (1h ,i6,f12.4,1p,(e15.4,4x,e15.4,4x,e15.4,4x,e15.4,4x,e15.4
     1,2x,e15.4))
  260 format (5h0m = ,i6,8h,   n = ,i4,12h,   mdata = ,i8)
  270 format (45h0singular value analysis of the least squares,42h probl
     1em,  a*x=b,  scaled as  (a*d)*y=b  .)
  280 format (19h0scaling option no.,i2,18h.  d is a diagonal,46h matrix
     1 with the following diagonal elements../(5x,10e12.4))
  290 format (50h0scaling option no. 1.   d is the identity matrix./1x)
  295 format (49h convergence failure in qr bidiagonal svd routine)
  300 format (6h0index,13x,28h         ynorm         rnorm,14x,28h  log1
     10(ynorm)  log10(rnorm)/1x)
  310 format (1h ,i4,14x,2e14.5,14x,2f14.5)
  320 format (54h0norms of solution and residual vectors for a range of,
     144h values of the levenberg-marquardt parameter,9h, lambda./1h0,4x
     2,42h        lambda         ynorm         rnorm,
     345h log10(lambda)     log10(ynorm)  log10(rnorm))
  330 format (5x,3e14.5,3f14.5)
      end


* X01FTEXT
*UPTODATE X01AAFTEXT
      DOUBLE PRECISION FUNCTION X01AAF(X)
C     NAG COPYRIGHT 1975
C     MARK 4.5 RELEASE
      DOUBLE PRECISION X
C     * PI *
C     RETURNS THE VALUE OF THE CONSTANT PI
C     THE X PARAMETER IS NOT USED
C     FOR DEC VAX 11/780
C     X01AAF = 3.14159265358979324D0
      X01AAF = 3.14159265358979324D0
      RETURN
      END
** END OF X01AAFTEXT
*UPTODATE X01ABFTEXT
      DOUBLE PRECISION FUNCTION X01ABF(X)
C     NAG COPYRIGHT 1975
C     MARK 4.5 RELEASE
      DOUBLE PRECISION X
C     * GAMMA *
C     RETURNS THE VALUE OF EULERS CONSTANT GAMMA WHERE
C     GAMMA = LIM(1+1/2+...+1/N - LOG(N)) AS N TENDS TO INFINITY
C     THE X PARAMETER IS NOT USED
C     FOR DEC VAX 11/780
C     X01ABF = 0.577215664901532861D0
      X01ABF = 0.577215664901532861D0
      RETURN
      END
** END OF X01ABFTEXT
* P01FTEXT
*UPTODATE P01AAFTEXT
      INTEGER FUNCTION P01AAF(IFAIL, ERROR, SRNAME)
C     MARK 1 RELEASE.  NAG COPYRIGHT 1971
C     MARK 3 REVISED
C     MARK 4A REVISED, IER-45
C     MARK 4.5 REVISED
C     MARK 7 REVISED (DEC 1978)
C     MARK 11 REVISED (FEB 1984)
C     RETURNS THE VALUE OF ERROR OR TERMINATES THE PROGRAM.
      INTEGER ERROR, IFAIL, NOUT
C$P 1
      DOUBLE PRECISION SRNAME
C     TEST IF NO ERROR DETECTED
      IF (ERROR.EQ.0) GO TO 20
C     DETERMINE OUTPUT UNIT FOR MESSAGE
      NOUT=6
C      CALL X04AAF (0,NOUT)
C     TEST FOR SOFT FAILURE
      IF (MOD(IFAIL,10).EQ.1) GO TO 10
C     HARD FAILURE
      WRITE (NOUT,99999) SRNAME, ERROR
C     ******************** IMPLEMENTATION NOTE ********************
C     THE FOLLOWING STOP STATEMENT MAY BE REPLACED BY A CALL TO AN
C     IMPLEMENTATION-DEPENDENT ROUTINE TO DISPLAY A MESSAGE AND/OR
C     ABORT THE PROGRAM.
C     *************************************************************
      STOP
C     SOFT FAIL
C     TEST IF ERROR MESSAGES SUPPRESSED
   10 IF (MOD(IFAIL/10,10).EQ.0) GO TO 20
      WRITE (NOUT,99999) SRNAME, ERROR
   20 P01AAF = ERROR
      RETURN
99999 FORMAT (1H0, 38HERROR DETECTED BY NAG LIBRARY ROUTINE , A8,
     * 11H - IFAIL = , I5//)
      END
** END OF P01AAFTEXT


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine lattice(vbra,vcut,nm1,nm2,nm3,
     >                   vlat_1,vlat_2,vlat_3,vsq,nv,ipmax,
     >                   iprint,istop)
c     ================================================================
c
      implicit   none
c
      character  sname*32
      character  istop*32
c
      integer    nv
      integer    ipmax
      integer    iprint
      integer    nm1
      integer    nm2
      integer    nm3
      integer    tn1p1
      integer    tn2p1
      integer    tn3p1
      integer    nt12
      integer    nt23
      integer    nt123
      integer    n1
      integer    n2
      integer    n3
      integer    i
c
      real*8     vlat_1(ipmax)
      real*8     vlat_2(ipmax)
      real*8     vlat_3(ipmax)
      real*8     vsq(ipmax)
      real*8     vn(3)
      real*8     vbra(3,3)
      real*8     vnsq
      real*8     vcut
      real*8     vcut2
      real*8     tol
      real*8     zero
c
      parameter (tol=1.0d-06)
      parameter (zero=0.0d0)
      parameter (sname='lattice')
c
c     ****************************************************************
c     Calculates lattice vectors .....................................
c     input:
c       vbra     : basis vectors for bravais lattice
c       vcut     : cut off radius for lattice vectors
c       nm1      : number of repeats of vbra(1)
c       nm2      : number of repeats of vbra(2)
c       nm3      : number of repeats of vbra(3)
c       ipmax    : dimension of array that will contain vectors
c     output:
c       vlat     : bravais lattice vectors
c       vsq      : square of length of lattice vectors
c       nv       : number of lattice vectors
c
c     ****************************************************************
c
c     ================================================================
      if(iprint.ge.1) then
         write(6,'(''  lattice:: nm1,nm2,nm3 = '',3i3)') nm1,nm2,nm3
         write(6,'(''  lattice:: Basis vectors'')')
         do n1=1,3
            write(6,'(5x,3f10.5)')  (vbra(n2,n1),n2=1,3)
         enddo
      endif
c     ================================================================
c     generate lattice vectors........................................
      nv=0
      vcut2=vcut*vcut+tol
      tn1p1=2*nm1+1
      tn2p1=2*nm2+1
      tn3p1=2*nm3+1
      nt12=tn1p1*tn2p1
      nt23=tn2p1*tn3p1
      nt123=nt12*tn3p1
      do i=1,nt123
	 n1=i-1
         n1=mod(n1,tn1p1)-nm1
         n2=(i-1)/tn1p1
         n2=mod(n2,tn2p1)-nm2
         n3=(i-1)/nt12
         n3=mod(n3,tn3p1)-nm3
         vn(1) = n1*vbra(1,1)+n2*vbra(1,2)+n3*vbra(1,3)
         vn(2) = n1*vbra(2,1)+n2*vbra(2,2)+n3*vbra(2,3)
         vn(3) = n1*vbra(3,1)+n2*vbra(3,2)+n3*vbra(3,3)
         vnsq=vn(1)*vn(1)+vn(2)*vn(2)+vn(3)*vn(3)
         if(vnsq.le.vcut2) then
            if(nv+1.gt.ipmax) then
               write(6,'('' lattice:: nv.gt.ipmax:'',2i5)')
     >                                nv,ipmax
               call fstop(sname)
            endif
c           ----------------------------------------------------------
            call ord3v(vlat_1,vlat_2,vlat_3,vsq,nv,vn,vnsq,istop)
c           ----------------------------------------------------------
         endif
      enddo
c     ================================================================
      if(iprint.ge.1) then
         write(6,'(/'' lattice: number of lattice vectors is'',
     >                i5)') nv
c        write(6,'('' n,vlat '',i5,4f10.5)')
c    >            (n1,vlat_1(n1),vlat_2(n1),vlat_3(n1),vsq(n1),n1=1,nv)
      endif
c
c     ================================================================
      if(sname.eq.istop) then
         call fstop(sname)
      else
         return
      endif
c
      end


!***********************************/
!	Name:非構造格子から構造格子へのデータ移動
!	Alias:CountUpVertexFromPoint
!	Description:セルiの補間に用いるセルjの頂点Pjがセルiの中に含まれるか判定して数え上げる
!	Type:Geom,CellCenter
!	Input:Geom,CC
!	Output:CC%PrimitiveVariable
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.12.05
!	Update:
!	Other:not parallelize
!***********************************/
    subroutine OCountUpVertexFromPoint(CUV)
    use StructVar_Mod
    implicit none

    type(CountUpVertex), intent(inout) :: CUV
    integer :: iLocalPoint

    CUV%iTotalVertexNum = 0

    do iLocalPoint=1, 3

        CUV%iInOrOut = CheckPointInternalTriangle(CUV%DonorCoords(iLocalPoint,1:3), &
        &   CUV%TargetCoords(1,1:3),CUV%TargetCoords(2,1:3),CUV%TargetCoords(3,1:3))

        if(CUV%iInOrOut == 1) then
            CUV%iTotalVertexNum = CUV%iTotalVertexNum + 1
            CUV%AdditionVertex(CUV%iTotalVertexNum,:) = CUV%DonorCoords(iLocalPoint,1:3)
        end if
    end do

    return
contains

    function CheckPointInternalTriangle(Point,Vertex1, Vertex2, Vertex3) result(TorF)
    implicit none
        double precision, intent(in) :: Point(:), Vertex1(:), Vertex2(:), Vertex3(:)
        integer :: TorF
        double precision, dimension(3,3) :: VertexOnRelatedCoords
        double precision :: AB, BC, CA, AA, BB

        VertexOnRelatedCoords(1,:) = Vertex1(:) - Point(:)
        VertexOnRelatedCoords(2,:) = Vertex2(:) - Point(:)
        VertexOnRelatedCoords(3,:) = Vertex3(:) - Point(:)

        AB = dot_product(VertexOnRelatedCoords(1,:),VertexOnRelatedCoords(2,:))
        BC = dot_product(VertexOnRelatedCoords(2,:),VertexOnRelatedCoords(3,:))
        CA = dot_product(VertexOnRelatedCoords(3,:),VertexOnRelatedCoords(1,:))
        AA = dot_product(VertexOnRelatedCoords(1,:),VertexOnRelatedCoords(1,:))

        if(AB*BC-AA*BC < 0.0d0) then
            TorF = 0
        else
            BB = dot_product(VertexOnRelatedCoords(2,:),VertexOnRelatedCoords(2,:))
            if(AB*BC-CA*BB < 0.0d0) then
                TorF = 0
            else
                TorF = 1
            end if
        end if

        return
    end function CheckPointInternalTriangle

end subroutine OCountUpVertexFromPoint