cc Copyright (C) 2009-2012: Leslie Greengard and Zydrunas Gimbutas
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c    $Date$
c    $Revision$
c
c
c     This file contains the main FMM routines and some related
c     subroutines for evaluating Cauchy sums due to
c     point charges and dipoles.  (FORTRAN 90 VERSION)
c
c       cfmm2d does the Cauchy type sums of complex valued
c       charges and dipoles - dipole vectors have no meaning in cfmm2d.
c
c cfmm2d: charge and dipstr are complex valued, z are complex numbers,
c       generalized Cauchy sums.
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 *(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
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     cfmm2dpart - Generalized Cauchy FMM in R^2: evaluate all pairwise particle
c         interactions (ignoring self-interaction)
c
c     cfmm2dpartself - Generalized Cauchy FMM in R^2: evaluate all pairwise
c         particle interactions (ignoring self-interaction)
c
c     cfmm2dparttarg - Generalized Cauchy FMM in R^2: evaluate all pairwise
c         particle interactions (ignoring self-interaction) +
c         interactions with targets
c
c     c2dpartdirect - Generalized Cauchy  interactions in R^2:  evaluate all
c         pairwise particle interactions (ignoring self-interaction) +
c         interactions with targets via direct O(N^2) algorithm
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        this is the end of the debugging code and the beginning
c        of the Laplace particle FMM in R^2
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
        subroutine cfmm2dpart(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess)
        implicit real *8 (a-h,o-z)
c
c       Generalized Cauchy FMM in R^2: evaluate all pairwise particle
c       interactions (ignoring self-interaction).
c
c       We use log(z) for the Green's function.
c       Self-interactions are not included.
c
c cfmm2d: 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       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 dipstr(*)
        complex *16 ima
        complex *16 pot(*)
        complex *16 grad(*)
        complex *16 hess(*)
c
        real *8 target(2,1)
        complex *16 pottarg(1)
        complex *16 gradtarg(1)
        complex *16 hesstarg(1)
c
        data ima/(0.0d0,1.0d0)/
c
        ntarget=0
        ifpottarg=0
        ifgradtarg=0
        ifhesstarg=0
c
        call cfmm2dparttarg(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     ntarget,target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dpartself(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess)
        implicit real *8 (a-h,o-z)
c
c       Generalized Cauchy FMM in R^2: evaluate all pairwise particle
c       interactions (ignoring self-interaction).
c
c       We use log(z) for the Green's function.
c       Self-interactions are not included.
c
c cfmm2d: 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       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 dipstr(*)
        complex *16 ima
        complex *16 pot(*)
        complex *16 grad(*)
        complex *16 hess(*)
c
        real *8 target(2,1)
        complex *16 pottarg(1)
        complex *16 gradtarg(1)
        complex *16 hesstarg(1)
c
        data ima/(0.0d0,1.0d0)/
c
        ntarget=0
        ifpottarg=0
        ifgradtarg=0
        ifhesstarg=0
c
        call cfmm2dparttarg(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     ntarget,target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dparttarg(ier,iprec,nsource,source,
     $     ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     ntarget,target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
        implicit real *8 (a-h,o-z)
c
c       Generalized Cauchy FMM in R^2: evaluate all pairwise particle
c       interactions (ignoring self-interaction)
c       and interactions with targets.
c
c       We use log(z) for the Green's function.
c       Self-interactions are not included.
c
c cfmm2d: 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       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       dipstr: complex *16 (nsource): dipole strengths
c       dipvec: real *8 (2,nsource): dipole orientation vectors.
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       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       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(*)
        complex *16 dipstr(*)
        complex *16 ima
        complex *16 pot(*)
        complex *16 grad(*)
        complex *16 hess(*)
c
        real *8 target(2,*)
        complex *16 pottarg(*)
        complex *16 gradtarg(*)
        complex *16 hesstarg(*)
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 ptemp,gtemp(2),htemp(3)
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=1
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
c
        if(ifprint .eq. 1) call prinf('nbox=*',nbox,1)
c
c
c     create quad-tree data structure
c
        t1=second()
C$        t1=omp_get_wtime()
        ntot = 100*(nsource+ntarget)+10000
        do ii = 1,10
           allocate (wlists(ntot))
           call lfmm2dparttree(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
c       ... prepare data structures
c
        do i = 0,nlev
        scale(i) = 1.0d0
        boxsize = abs((size/2.0**i))
ccc        if (boxsize .lt. 1) scale(i) = boxsize
        scale(i) = boxsize
        enddo
c
        if(ifprint .eq. 1) call prin2('scale=*',scale,nlev+1)
c
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     idipvecsort is pointer for sorted dipole orientation vectors
c     idipstrsort is pointer for sorted dipole densities
c
        isourcesort = lused7 + 5
        lsourcesort = 2*nsource
        itargetsort = isourcesort+lsourcesort
        ltargetsort = 2*ntarget
        ichargesort = itargetsort+ltargetsort
        lchargesort = 2*nsource
        idipvecsort = ichargesort+lchargesort
        if (ifdipole.eq.1) then
          ldipvec = 2*nsource
          ldipstr = 2*nsource
        else
          ldipvec = 2
          ldipstr = 2
        endif
        idipstrsort = idipvecsort + ldipvec
        lused7 = idipstrsort + ldipstr
c
c       ... allocate the potential and gradient arrays
c
        ipot = lused7
        lpot = 2*nsource
        lused7=lused7+lpot
c
        igrad = lused7
        if( ifgrad .eq. 1) then
        lgrad = 2*nsource
        else
        lgrad=4
        endif
        lused7=lused7+lgrad
c
        ihess = lused7
        if( ifhess .eq. 1) then
        lhess = 2*nsource
        else
        lhess=6
        endif
        lused7=lused7+lhess
c
        ipottarg = lused7
        lpottarg = 2*ntarget
        lused7=lused7+lpottarg
c
        igradtarg = lused7
        if( ifgradtarg .eq. 1) then
        lgradtarg = 2*ntarget
        else
        lgradtarg=4
        endif
        lused7=lused7+lgradtarg
c
        ihesstarg = lused7
        if( ifhesstarg .eq. 1) then
        lhesstarg = 2*ntarget
        else
        lhesstarg=6
        endif
        lused7=lused7+lhesstarg
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 lfmm2dpart, 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(2,nboxes).
c
c     iiaddr is pointer to iaddr array, itself contained in workspace.
c     imptemp is pointer for single expansion (dimensioned by nmax)
c
c       ... allocate iaddr and temporary arrays
c
        iiaddr = lused7
        imptemp = iiaddr + 2*nboxes
        lmptemp = (2*nmax+1)*2
        lused7 = imptemp + lmptemp
        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 c2dreorder(nsource,source,ifcharge,charge,wlists(iisource),
     $     ifdipole,dipstr,
     1     w(isourcesort),w(ichargesort),w(idipstrsort))
c
        call l2dreordertarg(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
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 l2dmpalloc(wlists(iwlists),w(iiaddr),nboxes,lmptot,nterms)
c
        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
ccc        do i=lused7+1,lused7+1+100
ccc        w(i)=777
ccc        enddo
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 cfmm2dparttargmain(ier,iprec,
     $     ifevalfar,ifevalloc,
     $     nsource,w(isourcesort),wlists(iisource),
     $     ifcharge,w(ichargesort),
     $     ifdipole,w(idipstrsort),
     $     ifpot,w(ipot),ifgrad,w(igrad),ifhess,w(ihess),
     $     ntarget,w(itargetsort),wlists(iitarget),
     $     ifpottarg,w(ipottarg),ifgradtarg,w(igradtarg),
     $     ifhesstarg,w(ihesstarg),
     $     epsfmm,w(iiaddr),wrmlexp(irmlexp),w(imptemp),lmptemp,
     $     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 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
ccc        call prin2('after w=*', w(1+lused7-100), 2*100)
c
        if(ifpot .eq. 1)
     $     call l2dpsort(nsource,wlists(iisource),w(ipot),pot)
        if(ifgrad .eq. 1)
     $     call l2dpsort(nsource,wlists(iisource),w(igrad),grad)
        if(ifhess .eq. 1)
     $     call l2dpsort(nsource,wlists(iisource),w(ihess),hess)
c
        if(ifpottarg .eq. 1 )
     $     call l2dpsort(ntarget,wlists(iitarget),w(ipottarg),pottarg)
        if(ifgradtarg .eq. 1)
     $     call l2dpsort(ntarget,wlists(iitarget),w(igradtarg),gradtarg)
        if(ifhesstarg .eq. 1)
     $     call l2dpsort(ntarget,wlists(iitarget),w(ihesstarg),hesstarg)
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dparttargmain(ier,iprec,
     $     ifevalfar,ifevalloc,
     $     nsource,sourcesort,isource,
     $     ifcharge,chargesort,
     $     ifdipole,dipstrsort,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,ntarget,
     $     targetsort,itarget,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg,
     $     epsfmm,iaddr,rmlexp,mptemp,lmptemp,
     $     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 dipstrsort(*)
        complex *16 ima
        complex *16 pot(*)
        complex *16 grad(*)
        complex *16 hess(*)
        real *8 targetsort(2,*)
        integer itarget(*)
        complex *16 pottarg(*)
        complex *16 gradtarg(*)
        complex *16 hesstarg(*)
        real *8 wlists(*)
        integer iaddr(2,nboxes)
        real *8 rmlexp(*)
        complex *16 mptemp(lmptemp)
        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 ptemp,gtemp,htemp
        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)/
ccc        save
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     Prints timing breakdown, list information, and other things if ifprint=2.
c
        ifprint=1
c
c
c       ... set the potential and gradient to zero
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
        do i=1,nsource
        if( ifpot .eq. 1) pot(i)=0
        if( ifgrad .eq. 1) then
           grad(i)=0
        endif
        if( ifhess .eq. 1) then
           hess(i)=0
        endif
        enddo
C$OMP END PARALLEL DO
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
        do i=1,ntarget
        if( ifpottarg .eq. 1) pottarg(i)=0
        if( ifgradtarg .eq. 1) then
           gradtarg(i)=0
        endif
        if( ifhesstarg .eq. 1) then
           hesstarg(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
c
        if (ifprint .ge. 2)
     $     call prinf('nterms_eval=*',nterms_eval,4*(nlev+1))
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 l2dzero(rmlexp(iaddr(1,ibox)),nterms(level))
        call l2dzero(rmlexp(iaddr(2,ibox)),nterms(level))
        endif
        enddo
C$OMP END PARALLEL DO
c
c
        if(ifprint .ge. 1)
     $     call prinf('=== STEP 1 (form mp) ====*',i,0)
        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(mptemp,lused,ier,i,j,ptemp,gtemp,htemp,cd)
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
c        ipts=box(9)
c        npts=box(10)
c        call prinf('ipts=*',ipts,1)
c        call prinf('npts=*',npts,1)
        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
        if( box(10) .eq. 0 ) goto 1200
c
        if (nkids .eq. 0) then
c
c       ... form multipole expansions
c
	    radius = (corners0(1,1) - center0(1))**2
	    radius = radius + (corners0(2,1) - center0(2))**2
	    radius = sqrt(radius)
c
            call l2dzero(rmlexp(iaddr(1,ibox)),nterms(level))
            if_use_trunc = 0

            if( ifcharge .eq. 1 ) then
            call l2dformmp(ier,scale(level),sourcesort(1,box(9)),
     1  	chargesort(box(9)),npts,center0,nterms(level),
     2          rmlexp(iaddr(1,ibox)))
            endif
c
cc               call prin2('after formmp, rmlexp=*',
cc     $            rmlexp(iaddr(1,ibox)),2*(2*nterms(level)+1))
c
            if (ifdipole .eq. 1 ) then
               call l2dzero(mptemp,nterms(level))
               call l2dformmp_dp(ier,scale(level),
     $           sourcesort(1,box(9)),
     1           dipstrsort(box(9)),
     $           npts,center0,nterms(level),
     2           mptemp)
              call l2dadd(mptemp,rmlexp(iaddr(1,ibox)),nterms(level))
            endif
         endif
c
 1200    continue
C$OMP END PARALLEL DO
 1300    continue
c
         t2=second()
C$        t2=omp_get_wtime()
ccc        call prin2('time=*',t2-t1,1)
         timeinfo(1)=t2-t1
c
         if(ifprint .ge. 1)
     $      call prinf('=== STEP 2 (form lo) ====*',i,0)
        t1=second()
C$        t1=omp_get_wtime()
c
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,ptemp,gtemp,htemp,cd,ilist,npts)
C$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(1)
         do 3251 ibox=1,nboxes
c
         call d2tgetb(ier,ibox,box,center0,corners0,wlists)
c
ccc         if( box(10) .eq. 0 ) goto 3251
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
c       ... prune all sourceless boxes
c
ccc         if( box(10) .eq. 0 ) nlist=0
c
c
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
c            ifdirect3 = 0
c
c            if( box1(10) .lt. (nterms(level1)+1)/2 .and.
c     $          box(10) .lt. (nterms(level1)+1)/2 ) ifdirect3 = 1
c
            ifdirect3 = 0
c
            if( ifdirect3 .eq. 0 ) then
               npts=box1(10)
               if_use_trunc = 0
c
               if( ifcharge .eq. 1 ) then
               call l2dformta_add(ier,scale(level0),
     $            sourcesort(1,box1(9)),
     1            chargesort(box1(9)),npts,center0,nterms(level0),
     2            rmlexp(iaddr(2,ibox)))
               endif
c
               if( ifdipole .eq. 1 ) then
               call l2dformta_dp_add(ier,scale(level0),
     1            sourcesort(1,box1(9)),dipstrsort(box1(9)),
     2            npts,center0,
     3            nterms(level0),rmlexp(iaddr(2,ibox)))
               endif
c
            else

            call cfmm2dpart_direct(box1,box,sourcesort,
     $         ifcharge,chargesort,ifdipole,dipstrsort,
     $         ifpot,pot,ifgrad,grad,ifhess,hess,
     $         targetsort,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $         ifhesstarg,hesstarg)
c
            endif
 3250    continue
c
 3251    continue
C$OMP END PARALLEL DO
c
         t2=second()
C$        t2=omp_get_wtime()
ccc        call prin2('time=*',t2-t1,1)
         timeinfo(2)=t2-t1
c
c
        if(ifprint .ge. 1)
     $      call prinf('=== STEPS 3,4,5 ====*',i,0)
        ifprune_list2 = 1
        if (ifpot.eq.1) ifprune_list2 = 0
        if (ifgrad.eq.1) ifprune_list2 = 0
        if (ifhess.eq.1) ifprune_list2 = 0
        call lfmm2d_list2
     $     (bsize,nlev,laddr,scale,nterms,rmlexp,iaddr,epsfmm,
     $     timeinfo,wlists,mptemp,lmptemp,
     $     ifprune_list2)
c
        if(ifprint .ge. 1)
     $     call prinf('=== STEP 6 (eval mp) ====*',i,0)
        t1=second()
C$        t1=omp_get_wtime()
c
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,ptemp,gtemp,htemp,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)
c
c       ... prune all sourceless boxes
c
ccc         if( box(10) .eq. 0 ) goto 3252
c
         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
c       ... prune all sourceless boxes
c
ccc         if( box(10) .eq. 0 ) nlist=0
c
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)
c
            level=box1(1)
c
c            ifdirect4 = 0
c
c            if (box1(10) .lt. (nterms(level)+1)/2 .and.
c     $         box(10) .lt. (nterms(level)+1)/2 ) ifdirect4 = 1
c
            ifdirect4 = 0
c
            if (ifdirect4 .eq. 0) then

            if( box(10) .gt. 0 )
     $         call c2dmpevalall(scale(level),center1,
     $         rmlexp(iaddr(1,jbox)),nterms(level),
     $         sourcesort(1,box(9)),box(10),
     $         ifpot,pot(box(9)),
     $         ifgrad,grad(box(9)),
     $         ifhess,hess(box(9)))

            if( box(12) .gt. 0 )
     $         call c2dmpevalall(scale(level),center1,
     $         rmlexp(iaddr(1,jbox)),nterms(level),
     $         targetsort(1,box(11)),box(12),
     $         ifpottarg,pottarg(box(11)),
     $         ifgradtarg,gradtarg(box(11)),
     $         ifhesstarg,hesstarg(box(11)))

            else

            call cfmm2dpart_direct(box1,box,sourcesort,
     $         ifcharge,chargesort,ifdipole,dipstrsort,
     $         ifpot,pot,ifgrad,grad,ifhess,hess,
     $         targetsort,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $         ifhesstarg,hesstarg)

            endif
        enddo
c
 3252   continue
C$OMP END PARALLEL DO
c
        t2=second()
C$        t2=omp_get_wtime()
ccc     call prin2('time=*',t2-t1,1)
        timeinfo(6)=t2-t1
c

        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
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
c
        call d2tgetb(ier,ibox,box,center0,corners0,wlists)
        call d2tnkids(box,nkids)
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
        if (nkids .eq. 0) then
c
c       ... evaluate local expansions
c
        level=box(1)
        npts=box(10)
c
        if (level .ge. 2) then

        if( box(10) .gt. 0 )
     $     call c2dtaevalall(scale(level),center0,
     $     rmlexp(iaddr(2,ibox)),nterms(level),
     $     sourcesort(1,box(9)),box(10),
     $     ifpot,pot(box(9)),ifgrad,grad(box(9)),
     $     ifhess,hess(box(9)))

        if( box(12) .gt. 0 )
     $     call c2dtaevalall(scale(level),center0,
     $     rmlexp(iaddr(2,ibox)),nterms(level),
     $     targetsort(1,box(11)),box(12),
     $     ifpottarg,pottarg(box(11)),ifgradtarg,gradtarg(box(11)),
     $     ifhesstarg,hesstarg(box(11)))

        endif
c
        endif
c
 6201   continue
C$OMP END PARALLEL DO
        t2=second()
C$        t2=omp_get_wtime()
ccc     call prin2('time=*',t2-t1,1)
        timeinfo(7)=t2-t1
c
c
 8000   continue
c
c
        if( ifevalloc .eq. 0 ) goto 9000
c
        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
c
        call d2tgetb(ier,ibox,box,center0,corners0,wlists)
        call d2tnkids(box,nkids)
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
        if (nkids .eq. 0) then
c
c       ... evaluate self interactions
c
        call cfmm2dpart_direct_self_sym(box,sourcesort,
     $     ifcharge,chargesort,ifdipole,dipstrsort,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     targetsort,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
c
c
c       ... retrieve list #1
c
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
c
            call cfmm2dpart_direct(box1,box,sourcesort,
     $         ifcharge,chargesort,ifdipole,dipstrsort,
     $         ifpot,pot,ifgrad,grad,ifhess,hess,
     $         targetsort,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $         ifhesstarg,hesstarg)
c
 6203       continue
        endif
c
 6202   continue
C$OMP END PARALLEL DO
c
ccc        call prin2('inside fmm, pot=*',pot,2*nsource)
ccc        call prin2('inside fmm, grad=*',grad,2*nsource)
ccc        call prin2('inside fmm, hess=*',hess,2*nsource)
c
c
        t2=second()
C$        t2=omp_get_wtime()
ccc     call prin2('time=*',t2-t1,1)
        timeinfo(8)=t2-t1
c
 9000   continue
c
ccc        call prinf('=== DOWNWARD PASS COMPLETE ===*',i,0)
c
        if (ifprint .ge. 1) call prin2('timeinfo=*',timeinfo,8)
c
        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)
        call prinf('nsource=*',nsource,1)
        call prinf('ntarget=*',ntarget,1)
        endif
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dpart_direct_self(box,
     $     source,ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
        implicit real *8 (a-h,o-z)
c
        integer box(15),box1(15)
c
        real *8 source(2,*)
        complex *16 charge(*),dipstr(*)
        real *8 target(2,*)
c
        complex *16 pot(*),grad(*),hess(*)
        complex *16 pottarg(*),gradtarg(*),hesstarg(*)
        complex *16 ptemp,gtemp,htemp
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 cpotgrad2d_sdp(source(1,i),
     $         ifcharge,charge(i),ifdipole,dipstr(i),
     1         source(1,j),ifpot,ptemp,ifgrad,gtemp,ifhess,htemp)
            if (ifpot .eq. 1) pot(j)=pot(j)+ptemp
            if (ifgrad .eq. 1) then
               grad(j)=grad(j)+gtemp
            endif
            if (ifhess .eq. 1) then
               hess(j)=hess(j)+htemp
            endif
 6150   continue
 6160   continue
        do j=box(11),box(11)+box(12)-1
        do i=box( 9),box( 9)+box(10)-1
            call cpotgrad2d_sdp(source(1,i),
     $         ifcharge,charge(i),ifdipole,dipstr(i),
     1         target(1,j),ifpottarg,ptemp,ifgradtarg,gtemp,
     $         ifhesstarg,htemp)
            if (ifpottarg .eq. 1) pottarg(j)=pottarg(j)+ptemp
            if (ifgradtarg .eq. 1) then
               gradtarg(j)=gradtarg(j)+gtemp
            endif
            if (ifhesstarg .eq. 1) then
               hesstarg(j)=hesstarg(j)+htemp
            endif
        enddo
        enddo
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dpart_direct_self_sym(box,
     $     source,ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
        implicit real *8 (a-h,o-z)
c
        integer box(15),box1(15)
c
        real *8 source(2,*)
        complex *16 charge(*),dipstr(*)
        real *8 target(2,*)
c
        complex *16 pot(*),grad(*),hess(*)
        complex *16 pottarg(*),gradtarg(*),hesstarg(*)
        complex *16 ptemp,gtemp,htemp
        complex *16 ptemp1,gtemp1,htemp1
        complex *16 ptemp2,gtemp2,htemp2
c
c
        do 6160 j=box(9),box(9)+box(10)-1
        do 6150 i=box(9),box(9)+box(10)-1
            if (i .ge. j) goto 6150
c            call cpotgrad2d_sdp_sym(source(1,i),source(1,j),
c     $         ifcharge,charge(i),charge(j),
c     $         ifdipole,dipstr(i),dipstr(j),
c     1         ifpot,ptemp1,ptemp2,
c     $         ifgrad,gtemp1,gtemp2,ifhess,htemp1,htemp2)
c            if (ifpot .eq. 1) then
c               pot(i)=pot(i)+ptemp1
c               pot(j)=pot(j)+ptemp2
c            endif
c            if (ifgrad .eq. 1) then
c               grad(i)=grad(i)+gtemp1
c               grad(j)=grad(j)+gtemp2
c            endif
c            if (ifhess .eq. 1) then
c               hess(i)=hess(i)+htemp1
c               hess(j)=hess(j)+htemp2
c            endif
            call cpotgrad2d_sdp_sym_add(source(1,i),source(1,j),
     $         ifcharge,charge(i),charge(j),
     $         ifdipole,dipstr(i),dipstr(j),
     1         ifpot,pot(i),pot(j),
     $         ifgrad,grad(i),grad(j),ifhess,hess(i),hess(j))
 6150   continue
 6160   continue
        do j=box(11),box(11)+box(12)-1
        do i=box( 9),box( 9)+box(10)-1
            call cpotgrad2d_sdp(source(1,i),
     $         ifcharge,charge(i),ifdipole,dipstr(i),
     1         target(1,j),ifpottarg,ptemp,ifgradtarg,gtemp,
     $         ifhesstarg,htemp)
            if (ifpottarg .eq. 1) pottarg(j)=pottarg(j)+ptemp
            if (ifgradtarg .eq. 1) then
               gradtarg(j)=gradtarg(j)+gtemp
            endif
            if (ifhesstarg .eq. 1) then
               hesstarg(j)=hesstarg(j)+htemp
            endif
        enddo
        enddo
c
        return
        end
c
c
c
c
c
        subroutine cfmm2dpart_direct(box,box1,
     $     source,ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
        implicit real *8 (a-h,o-z)
c
        integer box(15),box1(15)
c
        real *8 source(2,*)
        complex *16 charge(*),dipstr(*)
        real *8 target(2,*)
c
        complex *16 pot(*),grad(*),hess(*)
        complex *16 pottarg(*),gradtarg(*),hesstarg(*)
        complex *16 ptemp,gtemp,htemp
c
c
        do j=box1(9),box1(9)+box1(10)-1
        call cpotgrad2dall_sdp
     $     (source(1,box(9)),box(10),ifcharge,charge(box(9)),
     $     ifdipole,dipstr(box(9)),source(1,j),
     1     ifpot,ptemp,ifgrad,gtemp,ifhess,htemp)
        if (ifpot .eq. 1) pot(j)=pot(j)+ptemp
        if (ifgrad .eq. 1) then
          grad(j)=grad(j)+gtemp
        endif
        if (ifhess .eq. 1) then
          hess(j)=hess(j)+htemp
        endif
        enddo
c
        do j=box1(11),box1(11)+box1(12)-1
        call cpotgrad2dall_sdp
     $     (source(1,box(9)),box(10),ifcharge,charge(box(9)),
     $     ifdipole,dipstr(box(9)),target(1,j),
     $     ifpottarg,ptemp,ifgradtarg,gtemp,ifhesstarg,htemp)
        if (ifpottarg .eq. 1) pottarg(j)=pottarg(j)+ptemp
        if (ifgradtarg .eq. 1) then
          gradtarg(j)=gradtarg(j)+gtemp
        endif
        if (ifhesstarg .eq. 1) then
          hesstarg(j)=hesstarg(j)+htemp
        endif
        enddo
c
        return
        end
c
c
c
c
c
        subroutine c2dpartdirect(nsource,
     $     source,ifcharge,charge,ifdipole,dipstr,
     $     ifpot,pot,ifgrad,grad,ifhess,hess,
     $     ntarget,target,ifpottarg,pottarg,ifgradtarg,gradtarg,
     $     ifhesstarg,hesstarg)
        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(*),dipstr(*)
        real *8 target(2,*)
c
        complex *16 pot(*),grad(*),hess(*)
        complex *16 pottarg(*),gradtarg(*),hesstarg(*)
        complex *16 ptemp,gtemp,htemp
c
c
        do i=1,nsource
        if( ifpot .eq. 1) pot(i)=0
        if( ifgrad .eq. 1) then
           grad(i)=0
           grad(i)=0
        endif
        if( ifhess .eq. 1) then
           hess(i)=0
           hess(i)=0
           hess(i)=0
        endif
        enddo
c
        do i=1,ntarget
        if( ifpottarg .eq. 1) pottarg(i)=0
        if( ifgradtarg .eq. 1) then
           gradtarg(i)=0
           gradtarg(i)=0
        endif
        if( ifhesstarg .eq. 1) then
           hesstarg(i)=0
           hesstarg(i)=0
           hesstarg(i)=0
        endif
        enddo
c
        if( ifpot .eq. 1 .or. ifgrad .eq. 1 .or. ifhess .eq. 1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,ptemp,gtemp,htemp)
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 cpotgrad2d_sdp(source(1,i),
     $         ifcharge,charge(i),ifdipole,dipstr(i),
     1         source(1,j),ifpot,ptemp,ifgrad,gtemp,ifhess,htemp)
            if (ifpot .eq. 1) pot(j)=pot(j)+ptemp
            if (ifgrad .eq. 1) then
               grad(j)=grad(j)+gtemp
            endif
            if (ifhess .eq. 1) then
               hess(j)=hess(j)+htemp
            endif
 6150   continue
 6160   continue
C$OMP END PARALLEL DO
        endif
c
        if( ifpottarg .eq. 1 .or. ifgradtarg .eq. 1
     $      .or. ifhesstarg .eq. 1) then
C$OMP PARALLEL DO DEFAULT(SHARED)
C$OMP$PRIVATE(i,j,ptemp,gtemp,htemp)
cccC$OMP$SCHEDULE(DYNAMIC)
cccC$OMP$NUM_THREADS(4)
        do j=1,ntarget
        do i=1,nsource
            call cpotgrad2d_sdp(source(1,i),
     $         ifcharge,charge(i),ifdipole,dipstr(i),
     1         target(1,j),ifpottarg,ptemp,ifgradtarg,gtemp,
     $         ifhesstarg,htemp)
            if (ifpottarg .eq. 1) pottarg(j)=pottarg(j)+ptemp
            if (ifgradtarg .eq. 1) then
               gradtarg(j)=gradtarg(j)+gtemp
            endif
            if (ifhesstarg .eq. 1) then
               hesstarg(j)=hesstarg(j)+htemp
            endif
        enddo
        enddo
C$OMP END PARALLEL DO
        endif
c
        return
        end
c
c
c
c
c
        subroutine c2dreorder(nsource,source,
     $     ifcharge,charge,isource,ifdipole,
     1     dipstr,sourcesort,chargesort,dipstrsort)
        implicit real *8 (a-h,o-z)
        real *8 source(2,*),sourcesort(2,*)
        integer isource(*)
        complex *16 charge(*),chargesort(*),dipstr(*),dipstrsort(*)
c
ccc        call prinf('nsource=*',nsource,1)
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
        do i = 1,nsource
        sourcesort(1,i) = source(1,isource(i))
        sourcesort(2,i) = source(2,isource(i))
        if( ifcharge .ge. 1 ) then
        chargesort(i) = charge(isource(i))
        endif
        if (ifdipole .ge. 1) then
        dipstrsort(i) = dipstr(isource(i))
        endif
        enddo
C$OMP END PARALLEL DO
        return
        end
c
c
c
c
c


program addNumbers

! This simple program adds two numbers
   implicit none

! Type declarations
   real :: result
   real :: A, B, time, total_time, twist, rho, F_a_0, F_a_1, g_0, g_1, r, delta_t, delta_r, Radius
   real(kind = 8) :: EI_00, EI_01, EI_10, EI_11
   integer, parameter :: N = 100
   integer, parameter :: T = 10000000
   integer :: i,j

 ! Dynamic velocity arrays:
   real, dimension(N+2) :: V_0_new
   real, dimension(N+2) :: V_1_new
   real, dimension(N+2) :: V_0_old
   real, dimension(N+2) :: V_1_old

 ! Moments arrays:
   real, dimension(N+2) :: M_0_new
   real, dimension(N+2) :: M_1_new
   real, dimension(N+2) :: M_0_old
   real, dimension(N+2) :: M_1_old

 ! Dynamic displacement arrays:
   real, dimension(N+2) :: q_0_new
   real, dimension(N+2) :: q_1_new
   real, dimension(N+2) :: q_0_old
   real, dimension(N+2) :: q_1_old

 ! Radial position in the blade array:
   real, dimension(N+2) :: Radius_position

 ! Time position in the blade array:
   real, dimension(T+1) :: Time_position

 ! Root bending moments array:
   real, dimension(T+1) :: Root_M_0
   real, dimension(T+1) :: Root_M_1

 ! Tip velocity of the displacements array:
   real, dimension(T+1) :: Tip_V_0
   real, dimension(T+1) :: Tip_V_1

 ! Tip displacements array:
   real, dimension(T+1) :: Tip_q_0
   real, dimension(T+1) :: Tip_q_1

! Executable statements
 ! Get all arrays with initial value 0:
   V_0_new = 0.0
   V_1_new = 0.0
   V_0_old = 0.0
   V_1_old = 0.0
   M_0_new = 0.0
   M_1_new = 0.0
   M_0_old = 0.0
   M_1_old = 0.0
   q_0_new = 0.0
   q_1_new = 0.0
   q_0_old = 0.0
   q_1_old = 0.0
   Radius_position = 0.0
   Time_position = 0.0
   Root_M_0 = 0.0
   Root_M_1 = 0.0
   Tip_V_0 = 0.0
   Tip_V_1 = 0.0
   Tip_q_0 = 0.0
   Tip_q_1 = 0.0

 ! Main program
   total_time = 1.275
   time = 0
   A = -100.0 ! Amplitud aerodynamic force direction 1
   B = 0.0 ! Amplitud aerodynamic force direction 0

   ! Properties DEFINITION:
   EI_00 = (10**9)*1.5
   EI_11 = (10**9)*1.5
   EI_01 = 0
   EI_10 = 0
   twist = 0
   rho = 500.0
   F_a_0 = B
   F_a_1 = A
   g_0 = 0.0
   g_1 = 0.0
   Radius = 62.5
   delta_r = Radius/(N-1)

   ! Program loops iteration:

   do j = 1, T

      delta_t = total_time/T
      r = 0

      do i = 2, N+1
         ! Calculation of the velocity new values from the old step time:
         V_0_new(i) = V_0_old(i) + delta_t*((-1/rho)*((M_0_old(i+1)-(2*M_0_old(i))+M_0_old(i-1))/delta_r**2)+(F_a_0/rho)+ g_0)
         V_1_new(i) = V_1_old(i) + delta_t*((-1/rho)*((M_1_old(i+1)-(2*M_1_old(i))+M_1_old(i-1))/delta_r**2)+(F_a_1/rho)+ g_1)

         ! Boundary conditions at the ROOT position:
         V_0_new(1) = 0
         V_1_new(1) = 0
         V_0_new(2) = 0
         V_1_new(2) = 0

         ! Calculation of the bending moment from the new velocity values:
         M_0_new(i) = M_0_old(i) + delta_t*((EI_00*((V_0_new(i+1)-(2*V_0_new(i))+V_0_new(i-1))/delta_r**2)))! +EI_01*((V_1_new[i+1]-(2*V_1_new[i])+V_1_new[i-1])/delta_r**2)))
         M_1_new(i) = M_1_old(i) + delta_t*((EI_11*((V_1_new(i+1)-(2*V_1_new(i))+V_1_new(i-1))/delta_r**2)))! +EI_10*((V_0_new[i+1]-(2*V_0_new[i])+V_0_new[i-1])/delta_r**2)))

         ! Boundary conditions at the TIPS position:
         M_0_new(N+2) = 0
         M_1_new(N+2) = 0
         M_0_new(N+1) = 0
         M_1_new(N+1) = 0

         ! Calculation of the deformation value from the velocity calculated:
         q_0_new(i) = q_0_old(i) + delta_t*((V_0_old(i)))
         q_1_new(i) = q_1_old(i) + delta_t*((V_1_old(i)))

         ! Position control:
         Radius_position(i) = r
         r = r + delta_r

      end do

      ! Upload data to new time-step:
       V_0_old = V_0_new
       V_1_old = V_1_new
       M_0_old = M_0_new
       M_1_old = M_1_new
       q_0_old = q_0_new
       q_1_old = q_1_new

      ! Store data to plot:
       Root_M_0(j) = M_0_new(2)
       Root_M_1(j) = M_1_new(2)
       Tip_V_0(j) = V_0_new(N+1)
       Tip_V_1(j) = V_0_new(N+1)
       Tip_q_0(j) = q_0_new(N+1)
       Tip_q_1(j) = q_1_new(N+1)

      ! Time control:
       Time_position(j) = time
       time = time + delta_t

   end do

   print *, huge(EI_00)
   print *, 'The  ', M_1_new

OPEN(1, FILE='Tip_q_0.csv', FORM='formatted')
Do i = 1, T
   write(1, '(10F5.3)') Tip_q_0(i)
End do

OPEN(1, FILE='Tip_q_1.csv', FORM='formatted')
Do i = 1, T
   write(1, '(10F5.3)') Tip_q_1(i)
End do

OPEN(1, FILE='Root_M_0.csv', FORM='formatted')
Do i = 1, T
   write(1, '(10F5.3)') Root_M_0(i)
End do

OPEN(1, FILE='Root_M_1.csv', FORM='formatted')
Do i = 1, T
   write(1, '(10F5.3)') Root_M_1(i)
End do

OPEN(1, FILE='Radius_position.csv', FORM='formatted')
Do i = 1, N
   write(1, '(10F5.3)') Radius_position(i)
End do

OPEN(1, FILE='Time_position.csv', FORM='formatted')
Do i = 1, T
   write(1, '(10F5.3)') Time_position(i)
End do

OPEN(1, FILE='q_0_new.csv', FORM='formatted')
Do i = 1, N
   write(1, '(10F5.3)') q_0_new(i)
End do

OPEN(1, FILE='q_1_new.csv', FORM='formatted')
Do i = 1, N
   write(1, '(10F5.3)') q_1_new(i)
End do

OPEN(1, FILE='M_0_new.csv', FORM='formatted')
Do i = 1, N
   write(1, '(10F5.3)') M_0_new(i)
End do

OPEN(1, FILE='M_1_new.csv', FORM='formatted')
Do i = 1, N
   write(1, '(10F5.3)') M_1_new(i)
End do

end program addNumbers


Real Function frho(dmass)
  Save
  am0 = 0.77
  wid = 0.153
  fd = 0.25*wid**2/((dmass-am0)**2+0.25*wid**2)
  frho = fd
  Return
End Function frho


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief rhof(i,j,k,ismpl) calculates the density of the fluid (in kg/m^3),
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return rho  [kg/m^3]
!> @details
!> rhow(i,j,k,ismpl) calculates the density in (in kg/m^3) of brine,
!> given temperature (t, in c) pressure (p,in pa), and salinity (s, in
!> mol/L) at node(i,j,k)\n
!>
!> Source:\n
!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
!> GEOPHYSICS, 57(11), 1396–1408 (1992).
!> http://dx.doi.org/10.1190/1.1443207 \n\n
!>
!>   Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n \n
!>
!>  CODE VERIFICATION:\n
!>   INPUT:  TEMP = 298.15K  P =0.1013 MPa  S = 0.25 g/g      OUTPUT: RHO = 1187.35 kg/m3\n
!>   INPUT:  TEMP = 393.15K  P =   30 MPa   S = 0.10 g/g      OUTPUT: RHO = 1027.06 kg/m3\n\n
!>
!> ARGUMENTS NAME    TYPE    UNITS           DESCRIPTION\n
!>     INPUT:        Temp  Real    T                 C       Temperature \n
!>                         Real    P         Pa      Pressure\n
!>                         Real    S         g/g     Salinity in mass fraction\n
!>    OUTPUT:        LABEL            RHO            Real     kg/m3  Density of brine \n
      double precision function rhof(i,j,k,ismpl)
        use arrays, only: temp, pres, tsal
        use mod_flow, only: pa_conv1

        implicit none

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Temperature (degC)
        double precision :: t

        ! Pressure (MPa)
        double precision :: p

        ! Salinity (mol/L)
        double precision :: s

        ! Salinity fraction (g/L)
        double precision :: sr

        ! Molar mass of NaCl [g/mol]
        ! double precision, parameter :: mmnacl = 58.44277d0
        double precision, parameter :: mmnacl = 58.44d0

        ! Pure water density (kg/m3)
        double precision :: rw
        double precision, external :: rhow

        ! Pure water density (g/cm3)
        double precision :: rw_gcm3

        ! Fluid density (g/cm3)
        double precision :: rhof_gcm3

        ! Local Temperature (degC)
        t = temp(i,j,k,ismpl)

        ! Local Pressure [MPa]
        p = pres(i,j,k,ismpl)*pa_conv1

        ! Local salinity [mol/L]
        s = tsal(i,j,k,ismpl)

        ! Pure water density [kg/m3]
        rw = rhow(p,t)

        if (s<=0.0d0) then

          rhof = rw

        else

          ! mol/L (Molarity) > g/g (Mass fraCtion)
          sr = s*mmnacl/(rw+s*mmnacl)

          ! Pure water density [g/cm3]
          rw_gcm3 = rw / 1.0d3

          ! Batzle, Equation (27b), densities in g/cm3
          rhof_gcm3 = rw_gcm3 + sr*(0.668d0 + 0.44d0*sr &
              + 1.0D-6*(3.0d2*p - 2.4d3*p*sr &
              + t * (80.0d0 + 3.0d0*t - 3.3d3*sr - 13.0d0*p + 47.0d0*p*sr)))

          ! Fluid density [kg/m3]
          rhof = rhof_gcm3 * 1.0d3
        end if

        return

      end function rhof


       SUBROUTINE get_lambda(nsurf, zet, thet, aux1, iotac, fun,
     1   dfun, dlam)
       USE stel_kinds
       USE normalize_data, ONLY: lasym_v
       USE ballooning_data
       USE general_dimensions
       USE fmesh_quantities
       IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
       INTEGER, INTENT(in) :: nsurf
       REAL(rprec), INTENT(in) :: iotac, aux1, thet, zet
       REAL(rprec), INTENT(out) :: fun, dfun, dlam
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
       INTEGER :: j, lj
       REAL(rprec):: lamb, ccosi, ssine, arg
!-----------------------------------------------
       lamb = 0
       dlam = 0
       fourier: DO j = 1, mnmax_v
         arg = xm_v(j)*thet-xn_v(j)*zet
         ssine = sin(arg)
         ccosi = cos(arg)
         lj = mnmax_v*(nsurf-1)+j
         lamb = lamb + lmnsf(lj)*ssine                               ! Fourier invert lambda and d(lambda)/dzeta
         IF (lasym_v) lamb = lamb + lmnsf(lj)*ccosi
         dlam = dlam - xn_v(j)*lmnsf(lj)*ccosi
         IF (lasym_v) dlam = dlam + xn_v(j)*lmncf(lj)*ssine
       END DO fourier
       fun = aux1 + lamb - iotac*zet
       dfun = dlam - iotac

!      END SUBROUTINE fun00
      END


! Test for the ISNAN intrinsic
!
! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
!
  implicit none
  real :: x
  x = -1.0
  x = sqrt(x)
  if (.not. isnan(x)) call abort
  x = 0.0
  x = x / x
  if (.not. isnan(x)) call abort

  x = 5.0
  if (isnan(x)) call abort
  x = huge(x)
  x = 2*x
  if (isnan(x)) call abort
end


C Copyright(C) 2009-2017 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE INIGRD (FROM, TO, GRAD, NINT, NPTS, ARRAY)
C=======================================================================

C   $Id: inigrd.f,v 1.4 2009/03/25 12:46:02 gdsjaar Exp $
C   $Log: inigrd.f,v $
C   Revision 1.4  2009/03/25 12:46:02  gdsjaar
C   Add copyright and license notice to all files.
C
C   Revision 1.3  1992/01/02 18:55:16  gdsjaar
C   Moved from gen3d to here, overwrite old one
C
c Revision 1.2  1991/02/07  10:35:19  gdsjaar
c Removed Debug Comment lines from files
c
c Revision 1.1.1.1  90/08/20  12:21:56  gdsjaar
c Gen3D Mesh Generation Program
c
c Revision 1.1  90/08/20  12:21:55  gdsjaar
c Initial revision
c
C     INIGRD: Initialize array ARRAY with NPTS values.
C             values are calculated to have a gradient of GRAD
C             ranging from FROM to TO with NINT segments.
C
C --- FROM - IN - Minimum value of range
C --- TO   - IN - Maximum value of range
C --- GRAD - IN - Gradient
C --- NINT - IN - Number of intervals in range
C --- NPTS - IN - Number of points in range.  Can be less than NINT if
C                 do not need full range, but want gradient spacing
C                 based on full range.  Normally NPTS = NINT + 1
C --- ARRAY- OUT- Range of values
C
      REAL    ARRAY(NPTS)
      LOGICAL NOGRAD
C
      IF (FROM .EQ. TO  .OR. NINT .LE. 0) THEN
         CALL PRTERR ('PROGRAM',
     *      'invalid values passed to INIGRD')
         RETURN
      END IF

      NOGRAD = (ABS(GRAD - 1.0)/NINT .LE. 1.0e-7)
C
      IF (NOGRAD) THEN
         D3 = 1.0 / NINT
         DO 10 I=1, NPTS
            ARRAY(I) = D3 * (I-1)
   10    CONTINUE
      ELSE
         ARRAY(1) = 0.0
         D3 = (1.0 - GRAD) / (1.0 - GRAD**NINT)
         DO 20 I=2,NPTS
            ARRAY(I) = ARRAY(I-1) + D3 * GRAD**(I-2)
   20    CONTINUE
      END IF

      DO 30 I=1, NPTS
         ARRAY(I) = FROM + ARRAY(I) * (TO - FROM)
   30 CONTINUE
C
      RETURN
      END


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   DO loops with real and double precision index variables.

	program DO
	parameter( n = 26 )
	implicit double precision (d)
	parameter( X3$4 = (5.0 + (-0.8)) + (-0.8) )
	real rslts(N), expect(N)

	data  d2,  dn2,  x6,  x3,  x1,  xn2, i3, xnp8
     +      /2D0, -2D0, 6.0, 3.0, 1.0, -2.0,  3, -0.8  /

c       -- tests 1 - 8:
	data expect / 1.0, 2.0, 3.0, 4.1, 4.0, 6.1, 10.1, 8.1,
c       -- tests 9 - 15:
     +                0.0, 3.0, 5.0, 4.2, X3$4, 3.0, 9.0,
c       -- tests 16 - 21:
     +                0.0, 1.0, 2.0, 3.0, 20.0, 21.0,
c       -- tests 22 - 26:
     +                0.0, 4.0, 2.0, 2.0, 0.0            /

C ----------- tests 1, 2, 3, 5:    x = 1.0, 2.0, 3.0; 4.0

	i = 1
	do 10 x = 1.0, 3.0
		rslts(i) = x
		i = i + 1
10	continue
	rslts(5) = x

C ----------- tests 4, 6, 8, 7:    x = 4.1, 6.1, 8.1; 10.1

	do 20, x = 4.1, 8.3, 2.0
		i = x
20		rslts(i) = x
	rslts(7) = x

C ----------- tests 9, 10: zero trip loop  x = 3.0

	rslts(9) = 0.0
	do 30 x = x3, xn2, x1
30		rslts(9) = x
	rslts(10) = x

C ----------- tests 11, 12, 13:    x = 5.0, 4.2, 3.4; 2.6

	i = 10
	do 40 x = 5, i3, xnp8
		i = 1 + i
40		rslts(i) = x

C ----------- tests 14, 15:    y = 3.0, 5.0, 7.0; 9.0

	d = 7.9D0
	rslts(14) = 0.0
	do 50 y = i3, d, 2.0D0
50		rslts(14) = rslts(14) + 1.0
	rslts(15) = y

C ------- Double precision loops:  --------------------

C ----------- tests 16, 17, 18, 19:     d = 0.0, 1.0, 2.0; 3.0

	i = 16
	do 60, d = 0d0, .21D1
		rslts(i) = d
60		i = i + 1
	rslts(19) = d

C ----------- tests 20, 21:    d = 1.0, 3.0; 5.0

	i = 20
	rslts(22) = 0.0
	do 70, d = 1.0, i3, d2
		rslts(i) = i
70		i = 1 + i

C ----------- tests 22, 23:   (zero trip)   d = 4.0

	d = 4d0
	do 80 d = d, 5.9, dn2
80		rslts(22) = rslts(22) + 1.0
	rslts(23) = d

C ----------- tests 24, 25, 26:    d = 3.0, 5.0; 7.0

	i = 24
	rslts(26) = 0.0
	do 90, d = i3, x6 + .9, 2
		rslts(i) = 2.0
90		i = i + 1

C ----------- check  results:

	call check(rslts, expect, N)
	end


!!# FUNCTION MODULE <<FUN_xyAVERAGE>>
MODULE FUN_xyAVERAGE

!!## PURPOSE
!! Get averages in 2D.

!!## AUTHORS
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 14 April 2007 [waw]

!!## EXTERNAL MODULES
USE FUN_xyINTEGRAL                              !!((08-A-FUN_xyINTEGRAL.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))
USE FUN_xyINTEGRALX                             !!((07-A-FUN_xyINTEGRALX.f90))
USE FUN_xyINTEGRALY                             !!((07-A-FUN_xyINTEGRALY.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE
PRIVATE

!!## PROCEDURE OVERLOADING
![nocompile]!doesn't compile under ifort 9.1. why?
!INTERFACE xyAVERAGE
! MODULE PROCEDURE xyAVERAGE_Lin2Ls_Rsp
! MODULE PROCEDURE xyAVERAGE_Lin2Ls_Rdp
! MODULE PROCEDURE xyAVERAGE_Lin1Ls_Rsp
! MODULE PROCEDURE xyAVERAGE_Lin1Ls_Rdp
!END INTERFACE

INTERFACE xyAVERAGE_Lin2Ls
 MODULE PROCEDURE xyAVERAGE_Lin2Ls_Rsp
 MODULE PROCEDURE xyAVERAGE_Lin2Ls_Rdp
END INTERFACE

INTERFACE xyAVERAGE_Lin2Pg
 MODULE PROCEDURE xyAVERAGE_Lin2Pg_Rsp
 MODULE PROCEDURE xyAVERAGE_Lin2Pg_Rdp
END INTERFACE

INTERFACE xyAVERAGE_Lin1Ls
 MODULE PROCEDURE xyAVERAGE_Lin1Ls_Rsp
 MODULE PROCEDURE xyAVERAGE_Lin1Ls_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
![nocompile]!PUBLIC :: xyAVERAGE
PUBLIC :: xyAVERAGE_Lin2Ls
PUBLIC :: xyAVERAGE_Lin1Ls
PUBLIC :: xyAVERAGE_Lin2Ls_Rsp
PUBLIC :: xyAVERAGE_Lin2Ls_Rdp
PUBLIC :: xyAVERAGE_Lin2Pg
PUBLIC :: xyAVERAGE_Lin2Pg_Rdp
PUBLIC :: xyAVERAGE_Lin2Pg_Rsp

!!## CONTAINED PROCEDURES
CONTAINS

FUNCTION xyAVERAGE_Lin2Ls_Rsp(Lin2,Ls) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "09-A-FUN_xyAVERAGE_Lin2Ls.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin2Ls.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyAVERAGE_Lin2Ls_Rdp(Lin2,Ls) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "09-A-FUN_xyAVERAGE_Lin2Ls.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin2Ls.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyAVERAGE_Lin2Pg_Rsp(Lin2,N,Pg) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "09-A-FUN_xyAVERAGE_Lin2Pg.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin2Pg.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyAVERAGE_Lin2Pg_Rdp(Lin2,N,Pg) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "09-A-FUN_xyAVERAGE_Lin2Pg.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin2Pg.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyAVERAGE_Lin1Ls_Rsp(Lin1,Ls) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
INCLUDE "09-A-FUN_xyAVERAGE_Lin1Ls.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin1Ls.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyAVERAGE_Lin1Ls_Rdp(Lin1,Ls) RESULT(AVERAGE)
!!#### LOCAL MAPPINGS
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
INCLUDE "09-A-FUN_xyAVERAGE_Lin1Ls.f90.hdr"
!!--begin--
INCLUDE "09-A-FUN_xyAVERAGE_Lin1Ls.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module mod_crc
    implicit none
    private
    public :: crc16, crc16dim
    integer, parameter :: igenerator = 32773 ! z'8005' !b'1000000000000101'  ! x^16+x^15+x^2+1
contains
!--------------------------------------------------------------------------
    subroutine crc16(n, in, icrc)         ! iso 2.4.3.1, table a.9, table b.5
        integer, intent(in    ) :: n, in
        integer, intent(in out) :: icrc
        integer :: j, ibit1, ibit2
        do j = n - 1, 0, -1
            ibit1 = ibits(in  ,  j, 1)           ! jth bit                   bit [31......0]
            ibit2 = ibits(icrc, 15, 1)           ! sign bit of 16bit crc
            icrc  = ibits(ishft(icrc, 1), 0, 16) ! shift up 1bit, trim to 16bit
            if (ieor(ibit1, ibit2) == 1) icrc = ieor(icrc, igenerator)
        end do
    end subroutine crc16
!--------------------------------------------------------------------------
    subroutine crc16dim(n, in, icrc)
        integer, intent(in    ) :: n, in(:)
        integer, intent(in out) :: icrc
        integer :: i
        do i = 1, size(in)
            call crc16(n, in(i), icrc)
        end do
    end subroutine crc16dim
!--------------------------------------------------------------------------
end module mod_crc


MODULE ClassVelocidadeV

   USE ClassArrayFonteComplementosV
   USE ClassMatrizA

   ! Modulo que implementa a classe para a velocidade V

   IMPLICIT  NONE

   PRIVATE

   TYPE, PUBLIC :: VelocidadeV

      ! Atritubos Externos serao atualizados por outra rotina
      ! Atributos Internos serao atualizados na classe

      !---------Atributos Externos-----------------------
      INTEGER           :: Tn                                            ! Numero de passos de tempo resolvidos em paralelo
      INTEGER           :: Nx, Ny                                      ! Nx e Ny da malha
      DOUBLE PRECISION  :: Lx, Ly                                      ! Comprimento do dominio
      DOUBLE PRECISION  :: ht                                          ! Refinamento temporal (necessario por causa dos coeficientes)
      DOUBLE PRECiSION  :: Re                                          ! Numero de Reynolds (necessario por causa dos coeficientes)
      DOUBLE PRECISION  :: Tolerancia                                  ! Tolerancia no criterio de parada dos solvers
      !--------------------------------------------------

      !--------Atributos Internos------------------------
      DOUBLE PRECISION                                 :: hx, hy       ! hx e hy da malha

      ! ATENCAO: DEFINIR UMA VETOR DE VETORES E RESERVAR VARIAVEIS v0, v1, v2, v3, ..., vt dinamicamente (de acordo com o a ordem do metodo de projecao no futuro)
      DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE      :: v   ! Vetores da velocidade V
      DOUBLE PRECISION, DIMENSION(:, :), ALLOCATABLE      :: v_bp, v_ex, residuo
      DOUBLE PRECISION, DIMENSION(:),    ALLOCATABLE      :: v_ref
      DOUBLE PRECISION, DIMENSION(:),    ALLOCATABLE      :: normas_L2

      ! A matriz A de V
      TYPE ( MatrizA ) :: A

      TYPE (ArrayFonteComplementosV), DIMENSION(9) :: FonteComplementosV
      !--------------------------------------------------

      CONTAINS

         ! Metodos da Classe
         procedure :: init                    ! Metodo que inicia a classe
         procedure :: aplica_condicao_inicial !
         procedure :: calcula_termo_fonte
         procedure :: single_grid
         procedure :: calcula_residuo
         procedure :: calcula_norma_L2
         procedure :: escreve_matriz
         procedure :: escreve_comparacao

   END TYPE VelocidadeV

   CONTAINS

      SUBROUTINE init(self, Nx, Ny, Tn, Lx, Ly, ht, Re, Tolerancia)

         USE Subrotinas_MG_GS

         !------------ Metodo que inicia as variaveis gerais da malha ---------------------

         CLASS( VelocidadeV ), INTENT(INOUT) :: self

         INTEGER         , INTENT(IN) :: Nx, Ny, Tn
         DOUBLE PRECISION, INTENT(IN) :: Lx, Ly, ht, Re, Tolerancia

         INTEGER :: stencil

         ! Atualiando os atributos da classe
         self % Tn = Tn
         self % Lx = Lx
         self % Ly = Ly
         self % Re = Re
         self % ht = ht
         self % Tolerancia = Tolerancia

         ! Calculando hx e hy (o mesmo valor para u, v e p)
         self % hx = self % Lx / Nx
         self % hy = self % Ly / Ny

         ! Atencao: Nx e Ny depende do tipo de variavel considerada (u, v ou p)
         ! entao aqui sera "corrigido" Nx e Ny para a velocidade U
         ! Apos esta correcao vai aparecer no codigo self % Nx e self % Ny (corrigidos) e nao
         ! Nx-1 e Ny
         self % Nx = Nx
         self % Ny = Ny - 1

         ! Reservando os vetores v0, v1, vt
         ! Lembrando que a dimensao real e v0( Nx*(Ny-1) )
         ALLOCATE( self % v( self % Nx * self % Ny, self % Tn ), &
                   self % v_bp( self % Nx * self % Ny, self % Tn ), &
                   self % v_ex( self % Nx * self % Ny, self % Tn ), &
                   self % residuo( self % Nx * self % Ny, self % Tn ), &
                   self % normas_L2( self % Tn ), &
                   self % v_ref( self % Nx * self % Ny ) )

         ! Iniciando os vetores
         self % v(:, :) = 0.0d0
         self % v_bp(:, :) = 0.0d0
         self % v_ex(:, :) = 0.0d0
         self % v_ref(:) = 0.0d0
         self % residuo(:, :) = 0.0d0
         self % normas_L2(:) = 0.0d0

         !-------------------------- matriz A de V --------------------------------
         ! Inicializando a matriz A de U
         CALL self % A % init(self % Nx, self % Ny, &
                              self % hx, self % hy, self % ht, &
                              self % Re)

         ! Atribuindo um stencil a cada volume de A
         CALL self % A % atribui_stencils()

         ! Calculandos os coeficientes e posicoes dos stencils
         CALL self % A % stencils_v(1.0d0)
         !-------------------------- matriz A de V --------------------------------

         ! Inicializando o array de fontes de U
         DO stencil = 1, 9
            CALL self % FonteComplementosV(stencil) % init(stencil)
         END DO

         CALL calcula_exata(self)

         CALL Atualiza_Variaveis_MG_GS_V(self % Lx, self % Ly, &
                                         self % Nx, self % Ny, &
                                         self % Tolerancia, &
                                         3, 3, &
                                         50, &
                                         self % ht, &
                                         self % Re, self % Tn )

      END SUBROUTINE init

      SUBROUTINE aplica_condicao_inicial( self )
         USE FuncoesAlias

         CLASS (VelocidadeV), INTENT(INOUT) :: self

         INTEGER :: volume

         DO volume = 1, self % Nx * self % Ny

            self % v(volume, :) = v_inicial(0, volume)

         END DO

      END SUBROUTINE aplica_condicao_inicial

      SUBROUTINE calcula_exata( self )
         USE FuncoesAlias

         CLASS (VelocidadeV), INTENT(INOUT) :: self

         INTEGER :: volume, t

         DO t = 1, self % Tn

             DO volume = 1, self % Nx * self % Ny

                 self % v_ex(volume, t) = v_analitica(t, volume)

             END DO

         END DO

      END SUBROUTINE calcula_exata

      SUBROUTINE calcula_termo_fonte( self, t, t0, u, pressao, correcao)

         CLASS (VelocidadeV) :: self
         INTEGER :: t, t0
         DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: u, pressao, correcao

         INTEGER :: volume, pp, stencil
         DOUBLE PRECISION :: Dv, Av, Av0, Complemento

         DO volume = 1, self % Nx * self % Ny

            ! Stencil do volume
            stencil = self % A % v(volume)
            !stencil = self % A % calcula_stencil(volume)

            ! Calculando a Adveccao e Difusao
            CALL self % FonteComplementosV(stencil) % CalculaComplementos(t, t0, &
                                                                          volume, &
                                                                          self % Nx, &
                                                                          self % hx, self % hy, self % ht, &
                                                                          self % Re, &
                                                                          u(:, t), u(:, t0), &
                                                                          self % v(:, t), self % v(:, t0), &
                                                                          Dv, Av, Av0, Complemento, pp )

            ! Aqui esta o calculo do termo fonte
            self % v_bp(volume, t) =  self % ht*( -1.5d0*Av + 0.5d0*Av0 - &
                                      ( pressao(pp + self % Nx, t) - pressao(pp, t) )/(self % hx) - &
                                      ( correcao(pp + self % Nx, t) - correcao(pp, t) )/(self % hx) ) &
                                      + 2.0d0 * Complemento !+ Sx(t, pu) )

         END DO
      END SUBROUTINE calcula_termo_fonte

      SUBROUTINE single_grid( self, t, rb)

         USE GS

         CLASS (VelocidadeV) :: self

         INTEGER, INTENT(IN) :: t, rb

         ! Resolvendo com Gauss Seidel
         CALL GaussSeidel_UV( self % A, self % v, self % v_bp, t, rb)

      END SUBROUTINE single_grid

      SUBROUTINE calcula_residuo( self, t )

          USE Residuo

          CLASS (VelocidadeV) :: self

          INTEGER, INTENT(IN) :: t

          ! Calcula residuo
          CALL calcula_residuo_UV( self % A, self % v, self % v_bp, self % residuo, t )

      END SUBROUTINE calcula_residuo

      SUBROUTINE calcula_norma_L2( self, t )

          USE Residuo

          CLASS (VelocidadeV) :: self

          INTEGER, INTENT(IN) :: t

          ! Calcula residuo
          self % normas_L2(t) = SUM(self % residuo(:, t) * self % residuo(:, t))

      END SUBROUTINE calcula_norma_L2

      SUBROUTINE escreve_matriz(self, nome, vetor)

         CLASS (VelocidadeV) :: self

         CHARACTER(len=*), INTENT(IN) :: nome
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vetor

         INTEGER :: pv, i, j
         CHARACTER(len=(self % Nx*23)) :: linha
         CHARACTER(len=23) :: valor

         OPEN(UNIT=41, FILE=TRIM(ADJUSTL(nome)), STATUS='REPLACE', ACTION='WRITE')

         ! Para pontos internos
         DO j = 1, self % Ny
            DO i = 1, self % Nx

               pv = i + (j-1)* self % Nx

               WRITE(valor, "(1PE22.15)") vetor(pv)
               linha((i-1)*23+1:(i-1)*23+23) = valor

            END DO

            WRITE(41,1) linha

         END DO
         CLOSE(41)

         1 FORMAT( A )

      END SUBROUTINE escreve_matriz

      SUBROUTINE escreve_comparacao(self, tempo, nome, vetor)

         USE FuncoesAlias

         CLASS (VelocidadeV) :: self

         CHARACTER(len=*), INTENT(IN) :: nome
         INTEGER, INTENT(IN) :: tempo
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: vetor

         INTEGER :: pv, i, j, p_Linf
         DOUBLE PRECISION :: Linf

         1 FORMAT( 1PE22.15, 3X, 1PE22.15, 3X, 1PE22.15, 3X, I10, 3X, I10 )
         2 FORMAT( 1PE22.15, 1X, "= ht", /,  &
                   1PE22.15, 1X, "= Erro Maximo", /,  &
                   1PE22.15, 1X, "= Analitica (onde o erro aconteceu)", /, &
                   1PE22.15, 1X, "=  Numerica (onde o erro aconteceu)" )

         OPEN(UNIT=41, FILE=TRIM(ADJUSTL(nome)), STATUS='REPLACE', ACTION='WRITE')

         Linf   = 0.0d0
         p_Linf  = 0

         ! Para pontos internos
         DO j = 1, self % Ny
            DO i = 1, self % Nx

               pv = i + (j-1)* self % Nx

               !WRITE(41, 1) v_analitica(tempo, pv), vetor(pv), v_analitica(tempo, pv) - vetor(pv)

               IF ( ABS(v_analitica(tempo, pv) - vetor(pv)) > Linf ) THEN
                  Linf = ABS(v_analitica(tempo, pv) - vetor(pv))
                  p_Linf  = pv
               END IF

            END DO

         END DO

         WRITE(41, 2) self % ht, Linf, v_analitica(tempo, p_Linf), vetor(p_Linf)

         CLOSE(41)

      END SUBROUTINE escreve_comparacao

END MODULE ClassVelocidadeV


subroutine compute_exact()
    implicit none

    double precision pi, pi2
    common /compi/ pi, pi2

    double precision xc, yc, xp, yp, zp, tfinal
    double precision x0,y0,x1,y1
    integer N, i

    open(10,file='ring.dat')
    read(10,*) N
    read(10,*) tfinal

    open(20,file='ring.out')
    do i = 1,N
        read(10,*) xp, yp, zp

        call map2comp(xp,yp,zp,x0,y0)

        call evolve_point(x0,y0,tfinal,x1,y1)
        write(20,*) x1,y1
    end do
    close(10)
    close(20)

end subroutine compute_exact

subroutine evolve_point(x0,y0,tfinal,x1,y1)
    implicit none

    external qexact_rhs
    external solout

    double precision x0,y0,tfinal,x1,y1

    double precision sigma(3), rtol, atol
    integer itol, iout

    integer Nmax, lwork,nrdens, liwork
    parameter(Nmax=4, nrdens=0)
    parameter(lwork=8*Nmax+5*nrdens+21)
    parameter(liwork=nrdens+21)

    double precision work(lwork), rpar(1)
    integer iwork(liwork), ipar(2), idid

    double precision t0
    integer i

!!  # ------------------------------------------
!!  # Numerical parameters
!!  # ------------------------------------------

    itol = 0
    rtol = 1.d-14
    atol = 1.d-14
    iout = 0

    do i = 1,20
        work(i) = 0
        iwork(i) = 0
    end do

!!  # Evolve from t=t0 to t=tfinal
    t0 = 0

!!  # Initial conditions for ODE

    sigma(1) = x0
    sigma(2) = y0
    sigma(3) = 0

!!  # Needed for backward trace
    rpar(1) = tfinal

!!  # Trace forwards
    ipar(1) = 1

!!  # This traces the velocity field back to the origin.

    call dopri5(3,qexact_rhs,t0,sigma,tfinal, &
                 rtol,atol,itol, &
                 solout,iout, work,lwork,iwork,liwork, &
                 rpar,ipar,idid)

    if (idid .ne. 1) then
        write(6,*) 'DOPRI5 : idid .ne. 1'
        stop
    endif

!!  # Initial position in [0,1]x[0,1]

    x1 = sigma(1)
    y1 = sigma(2)

end subroutine evolve_point


subroutine SHMTVar(l, tapers, taper_order, lwin, kmax, Sff, variance, &
                   taper_wt, unweighted_covar, nocross, exitstatus)
!------------------------------------------------------------------------------
!
!   Given the first Kmax tapers of a matrix TAPERS, and an input global power
!   spectrum Sff, this subroutine will compute the theoretical variance of a
!   multitaper spectral estimate at a given degree l, and for a given set of
!   optional input taper weights. This routine works only using the tapers of
!   the spherical-cap concentration problem.
!
!   Calling Parameters
!
!       IN
!           l               The single spherical harmonic degree to compute.
!           tapers          An array of (lwin+1, kmax) tapers (arranged in
!                           columns).
!           taper_order     An array of dimension kmax containing the REAL
!                           angular order of the tapers.
!           lwin            Maximum spherical harmonic degree of the
!                           bandlimited tapers.
!           kmax            Maximum number of tapers to be used in making the
!                           spectral estimate.
!           Sff             Known global power spectrum of the unwindowed
!                           field.
!
!       OUT
!           variance        The variance at spherical harmonic degree l.
!
!       OPTIONAL (IN)
!           taper_wt        Vector of dimension (kmax) containing the numerical
!                           values of the weights to be applied to each
!                           spectral estimate.
!           nocross         If present and equal to 1, then the off-diagonal
!                           terms of the covariance matrix will be assumed to
!                           be zero.
!
!       OPTIONAL (OUT)
!           unweighted_covar   Unweighted covariance matrix, Fij
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: SHSjkPG
    use ftypes

    implicit none

    real(dp), intent(in) :: tapers(:,:), Sff(:)
    real(dp), intent(out) :: variance
    integer(int32), intent(in) :: l, lwin, kmax, taper_order(:)
    real(dp), intent(in), optional :: taper_wt(:)
    real(dp), intent(out), optional :: unweighted_covar(:, :)
    integer(int32), intent(in), optional :: nocross
    integer(int32), intent(out), optional :: exitstatus
    real(dp) :: Fij(kmax, kmax)
    integer(int32) :: i, j, m, mp
    complex(dp) :: temp1

    if (present(exitstatus)) exitstatus = 0

    if (size(Sff) < l+lwin + 1) then
        print*, "Error --- SHMTVar"
        print*, "Sff must be dimensioned (L+LWIN+1) where L and LWIN " // &
                "are ", l, lwin
        print*, "Input array is dimensioned ", size(Sff)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(tapers(:,1)) < lwin+1 .or. size(tapers(1,:)) < kmax) then
        print*, "Error --- SHMTVar"
        print*, "TAPERS must be dimensioned as (LWIN+1, KMAX) where " // &
                "LWIN and KMAX are ", lwin, kmax
        print*, "Input array is dimensioned ", size(tapers(:,1)), &
                size(tapers(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(taper_order) < kmax) then
        print*, "Error --- SHMTVar"
        print*, "TAPER_ORDER must be dimensioned as (KMAX) where KMAX is ", &
                kmax
        print*, "Input array is dimensioned ", size(taper_order)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(taper_wt)) then
        if (size(taper_wt(:)) < kmax) then
            print*, "Error --- SHMTVar"
            print*, "TAPER_WT must be dimensioned (KMAX) " // &
                    "where KMAX is ", kmax
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(unweighted_covar)) then
        if (size(unweighted_covar(:,1)) < kmax .or. &
                size(unweighted_covar(1,:)) < kmax) then
            print*, "Error --- SHMTVar"
            print*, "UNWEIGHTED_COVAR must be dimensioned (KMAX, KMAX) " // &
                    "where KMAX is ", kmax
            print*, "Input array is dimensioned ", &
                    size(unweighted_covar(:,1)), size(unweighted_covar(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(nocross)) then
        if (nocross /= 1 .and. nocross /= 0) then
            print*, "Error --- SHMTVar"
            print*, "NOCROSS must be either 0 (use all elements of " // &
                    "covariance matrix) or"
            print*, "1 (set off-diagonal elements of " // &
                    "covariance matrix to zero)."
            print*, "Input value is ", nocross
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    end if

    Fij = 0.0_dp
    variance = 0.0_dp

    !--------------------------------------------------------------------------
    !
    !   Calculate matrix Fij
    !
    !--------------------------------------------------------------------------
    if (present(nocross)) then
        if (nocross == 1) then
            do i = 1, kmax, 1
                do m = -l, l
                    do mp = -l, l
                        temp1 = SHSjkPG(Sff, l, m, mp, tapers(1:lwin+1,i), &
                                        tapers(1:lwin+1,i), taper_order(i), &
                                        taper_order(i), lwin, 1)
                        Fij(i,i) = Fij(i,i) + 2.0_dp * dble(temp1 * conjg(temp1))

                    end do

                end do

            end do

        else
            do i = 1, kmax, 1
                do j = i, kmax, 1
                    do m = -l, l
                        do mp = -l, l
                            temp1 = SHSjkPG(Sff, l, m, mp, &
                                            tapers(1:lwin+1,i), &
                                            tapers(1:lwin+1,j), &
                                            taper_order(i), taper_order(j), &
                                            lwin, 1)
                            Fij(i,j) = Fij(i,j) + &
                                       2.0_dp * dble(temp1 * conjg(temp1))

                        end do

                    end do

                    if (i /= j) Fij(j,i) = Fij(i,j)

                end do

            end do

        end if

    else
        do i = 1, kmax, 1
            do j = i, kmax, 1
                do m = -l, l
                    do mp = -l, l
                        temp1 = SHSjkPG(Sff, l, m, mp, tapers(1:lwin+1,i), &
                                        tapers(1:lwin+1,j), taper_order(i), &
                                        taper_order(j), lwin, 1)
                        Fij(i,j) = Fij(i,j) + 2.0_dp * dble(temp1 * conjg(temp1))

                    end do

                end do

                if (i /= j) Fij(j,i) = Fij(i,j)

            end do

        end do

    end if

    if (present(unweighted_covar)) then
        unweighted_covar = 0.0_dp
        unweighted_covar(1:kmax, 1:kmax) = Fij(1:kmax,1:kmax)

    end if

    !----------------------------------------------------------------------
    !
    !   Calculate variances either using input weights, or equal weights.
    !
    !----------------------------------------------------------------------
    if (present(taper_wt)) then
        do i = 1, kmax
            do j = 1, kmax
                variance = variance + Fij(i, j) * taper_wt(i) * taper_wt(j)

            end do
        end do

    else
        variance = sum(Fij(1:kmax,1:kmax)) / dble(kmax)**2

    end if

end subroutine SHMTVar


!   =====================================================
subroutine rpt2(ixy,imp,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,aux1,aux2,aux3,asdq,bmasdq,bpasdq)
!   =====================================================

        implicit double precision (a-h,o-z)

!     # Riemann solver in the transverse direction for 2D Burgers' equation
!
!     # Split asdq into eigenvectors of Roe matrix B.
!     # For the scalar equation, this simply amounts to computing the
!     # transverse wave speed from the opposite Riemann problem.

        dimension    ql(meqn, 1-mbc:maxm+mbc)
        dimension    qr(meqn, 1-mbc:maxm+mbc)
        dimension   asdq(meqn, 1-mbc:maxm+mbc)
        dimension bmasdq(meqn, 1-mbc:maxm+mbc)
        dimension bpasdq(meqn, 1-mbc:maxm+mbc)

!     # x- and y- Riemann problems are identical, so it doesn't matter if
!     # ixy=1 or 2.

        do 10 i = 2-mbc, mx+mbc
            sb = 0.5d0*(qr(1,i-1) + ql(1,i))
            bmasdq(1,i) = dmin1(sb, 0.d0) * asdq(1,i)
            bpasdq(1,i) = dmax1(sb, 0.d0) * asdq(1,i)
        10 continue

    return
    end subroutine rpt2


**********************************************************************
*
*     Subroutine DLITVM                             Called by: DGQTST
*
*     solve (L**T)*X = Y, where L is an NxN lower triangular matrix
*     stored compactly by rows.  X and Y may occupy the same storage.
*
**********************************************************************
      SUBROUTINE DLITVM(N,X,L,Y)
*
*     subroutine arguments
*
      INTEGER*4 N
      DOUBLE PRECISION X(*),L(*),Y(*)
*
*     local vars
*
      INTEGER*4 I,II,I0,J
      DOUBLE PRECISION XI
*
*
*
      DO 10 I = 1,N
         X(I) = Y(I)
 10   CONTINUE
      I0 = N*(N+1)/2
      DO 30 II = 1,N
         I = N + 1 - II
         XI = X(I)/L(I0)
         X(I) = XI
         IF (I .LE. 1) RETURN
         I0 = I0 - I
         DO 20 J=1,I-1
            X(J) = X(J) - XI*L(I0+J)
 20      CONTINUE
 30   CONTINUE

      RETURN
      END