CCC   'cerjan.f' CERJAN ABSORBING BOUNDARY CONDITIONS

      subroutine inicrj(coords,maxdim,nxt,nyt,nzt,ndt,nx,ny,arbc)

CCC   ROUTINE TO INITIALIZE DAMPING SERIES

      use parstat

      integer :: nxt,nyt,nzt,ndt,nx,ny
      integer :: nxp,nyp,nzp

      real :: arbc

      integer, dimension(maxdim) :: coords

C     SCALE DAMPING FOR ABC WIDTH

      alpha=sqrt(-log(arbc))/ndt

      flag_cerjanx=0
      flag_cerjany=0
      flag_cerjanz=0
      xs_crj = 1
      xe_crj = -1
      ys_crj = 1
      ye_crj = -1
      zs_crj = 1
      ze_crj = -1

C     FIND CERJAN NODES AND INITIALIZE

      nxp = coords(1)*nxt + 1
      if(nxp <= ndt) then

        flag_cerjanx=1
        xs_crj(1) = 1
        xe_crj(1) = ndt
        ys_crj(1) = 1
        ye_crj(1) = nyt
        zs_crj(1) = 1
        ze_crj(1) = nzt

        allocate(dcrjx(xs_crj(1):xe_crj(1),ys_crj(1):ye_crj(1),zs_crj(1):ze_crj(1)))
        dcrjx=1

        do i=xs_crj(1),xe_crj(1)
        do j=ys_crj(1),ye_crj(1)
        do k=zs_crj(1),ze_crj(1)

          nxp = coords(1)*nxt + i
          dcrjx(i,j,k) = dcrjx(i,j,k)*(exp(-((alpha*(ndt-nxp+1))**2)))

        end do
        end do
        end do

      else if( (nxp+nxt-1) >= (nx-ndt+1)) then

        flag_cerjanx=2
        xs_crj(1) = nxt-ndt+1
        xe_crj(1) = nxt
        ys_crj(1) = 1
        ye_crj(1) = nyt
        zs_crj(1) = 1
        ze_crj(1) = nzt

        allocate(dcrjx(xs_crj(1):xe_crj(1),ys_crj(1):ye_crj(1),zs_crj(1):ze_crj(1)))
        dcrjx=1

        do i=xs_crj(1),xe_crj(1)
        do j=ys_crj(1),ye_crj(1)
        do k=zs_crj(1),ze_crj(1)

          nxp = coords(1)*nxt + i
          dcrjx(i,j,k) = dcrjx(i,j,k)*(exp(-((alpha*(ndt-(nx-nxp)))**2)))

        end do
        end do
        end do

      end if

      nyp = coords(2)*nyt + 1
      if(nyp <= ndt) then

         flag_cerjany=1
         if(flag_cerjanx==1) then
           xs_crj(2) = xe_crj(1)+1
           xe_crj(2) = nxt
         else if(flag_cerjanx==2) then
           xs_crj(2) = 1
           xe_crj(2) = xs_crj(1)-1
         else
           xs_crj(2) = 1
           xe_crj(2) = nxt
         end if
         ys_crj(2) = 1
         ye_crj(2) = ndt
         zs_crj(2) = 1
         ze_crj(2) = nzt

         do i=xs_crj(1),xe_crj(1)
         do j=ys_crj(2),ye_crj(2)
         do k=zs_crj(2),ze_crj(2)

           nyp = coords(2)*nyt + j
           dcrjx(i,j,k) = dcrjx(i,j,k)*(exp(-((alpha*(ndt-nyp+1))**2)))

         end do
         end do
         end do

         allocate(dcrjy(xs_crj(2):xe_crj(2),ys_crj(2):ye_crj(2),zs_crj(2):ze_crj(2)))
         dcrjy=1

         do i=xs_crj(2),xe_crj(2)
         do j=ys_crj(2),ye_crj(2)
         do k=zs_crj(2),ze_crj(2)

           nyp = coords(2)*nyt + j
           dcrjy(i,j,k) = dcrjy(i,j,k)*(exp(-((alpha*(ndt-nyp+1))**2)))

         end do
         end do
         end do

      else if( (nyp+nyt-1) >= (ny-ndt+1)) then

         flag_cerjany=2
         if(flag_cerjanx==1) then
           xs_crj(2) = xe_crj(1)+1
           xe_crj(2) = nxt
         else if(flag_cerjanx==2) then
           xs_crj(2) = 1
           xe_crj(2) = xs_crj(1)-1
         else
           xs_crj(2) = 1
           xe_crj(2) = nxt
         end if
         ys_crj(2) = nyt-ndt+1
         ye_crj(2) = nyt
         zs_crj(2) = 1
         ze_crj(2) = nzt

         do i=xs_crj(1),xe_crj(1)
         do j=ys_crj(2),ye_crj(2)
         do k=zs_crj(2),ze_crj(2)

           nyp = coords(2)*nyt + j
           dcrjx(i,j,k) = dcrjx(i,j,k)*(exp(-((alpha*(ndt-(ny-nyp)))**2)))

         end do
         end do
         end do

         allocate(dcrjy(xs_crj(2):xe_crj(2),ys_crj(2):ye_crj(2),zs_crj(2):ze_crj(2)))
         dcrjy=1

         do i=xs_crj(2),xe_crj(2)
         do j=ys_crj(2),ye_crj(2)
         do k=zs_crj(2),ze_crj(2)

           nyp = coords(2)*nyt + j
           dcrjy(i,j,k) = dcrjy(i,j,k)*(exp(-((alpha*(ndt-(ny-nyp)))**2)))

         end do
         end do
         end do

      end if

      nzp = coords(3)*nzt + 1
      if(nzp <= ndt) then

         flag_cerjanz=1

         if(flag_cerjanx==1) then
           xs_crj(3) = xe_crj(1)+1
           xe_crj(3) = nxt
         else if(flag_cerjanx==2) then
           xs_crj(3) = 1
           xe_crj(3) = xs_crj(1)-1
         else
           xs_crj(3) = 1
           xe_crj(3) = nxt
         end if

         ys_crj(3) = 1
         ye_crj(3) = nyt
         zs_crj(3) = 1
         ze_crj(3) = ndt

         do i=xs_crj(1),xe_crj(1)
         do j=ys_crj(3),ye_crj(3)
         do k=zs_crj(3),ze_crj(3)

           nzp = coords(3)*nzt + k
           dcrjx(i,j,k) = dcrjx(i,j,k)*(exp(-((alpha*(ndt-nzp+1))**2)))

         end do
         end do
         end do

         if(flag_cerjany==1) then
           ys_crj(3) = ye_crj(2)+1
           ye_crj(3) = nyt
         else if(flag_cerjany==2) then
           ys_crj(3) = 1
           ye_crj(3) = ys_crj(2)-1
         else
           ys_crj(3) = 1
           ye_crj(3) = nyt
         end if

         do i=xs_crj(3),xe_crj(3)
         do j=ys_crj(2),ye_crj(2)
         do k=zs_crj(3),ze_crj(3)

           nzp = coords(3)*nzt + k
           dcrjy(i,j,k) = dcrjy(i,j,k)*(exp(-((alpha*(ndt-nzp+1))**2)))

         end do
         end do
         end do

         allocate(dcrjz(xs_crj(3):xe_crj(3),ys_crj(3):ye_crj(3),zs_crj(3):ze_crj(3)))
         dcrjz=1

         do i=xs_crj(3),xe_crj(3)
         do j=ys_crj(3),ye_crj(3)
         do k=zs_crj(3),ze_crj(3)

           nzp = coords(3)*nzt + k
           dcrjz(i,j,k) = dcrjz(i,j,k)*(exp(-((alpha*(ndt-nzp+1))**2)))

         end do
         end do
         end do

      end if

      return
      end

      subroutine addcrjstr(nxt, nyt, nzt )
      use parstat
      integer :: nxt, nyt, nzt

      if(flag_cerjanx>0) then
         call addcrjstr_loop(dcrjx, xs_crj(1), xe_crj(1), ys_crj(1), ye_crj(1), zs_crj(1), ze_crj(1))
      end if
      if(flag_cerjany>0) then
         call addcrjstr_loop(dcrjy, xs_crj(2), xe_crj(2), ys_crj(2), ye_crj(2), zs_crj(2), ze_crj(2))
      end if
      if(flag_cerjanz==1) then
         call addcrjstr_loop(dcrjz, xs_crj(3), xe_crj(3), ys_crj(3), ye_crj(3), zs_crj(3), ze_crj(3))
      end if

      return
      end

      subroutine addcrjstr_loop(dcrj, i_b, i_e, j_b, j_e, k_b, k_e)
      use parstat
      integer :: i, j, k, kk, jj
      integer :: i_b, i_e, j_b, j_e, k_b, k_e
      real, dimension(i_b:i_e,j_b:j_e,k_b:k_e) :: dcrj

      do kk= k_b,k_e,kblock
      do jj= j_b,j_e,jblock
      do 20 k= kk,min(kk+kblock-1,k_e)
      do 20 j= jj,min(jj+jblock-1,j_e)

      xx(i_b:i_e,j,k) = xx(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      yy(i_b:i_e,j,k) = yy(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      zz(i_b:i_e,j,k) = zz(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      xz(i_b:i_e,j,k) = xz(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      yz(i_b:i_e,j,k) = yz(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      xy(i_b:i_e,j,k) = xy(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)

   20 continue
      end do
      end do

      return
      end

      subroutine addcrjvel(nxt, nyt, nzt)
      use parstat
      integer :: nxt, nyt, nzt

      if(flag_cerjanx>0) then
         call addcrjvel_loop(dcrjx, xs_crj(1), xe_crj(1), ys_crj(1), ye_crj(1), zs_crj(1), ze_crj(1))
      end if
      if(flag_cerjany>0) then
         call addcrjvel_loop(dcrjy, xs_crj(2), xe_crj(2), ys_crj(2), ye_crj(2), zs_crj(2), ze_crj(2))
      end if
      if(flag_cerjanz==1) then
         call addcrjvel_loop(dcrjz, xs_crj(3), xe_crj(3), ys_crj(3), ye_crj(3), zs_crj(3), ze_crj(3))
      end if

      return
      end

      subroutine addcrjvel_loop(dcrj, i_b, i_e, j_b, j_e, k_b, k_e)
      use parstat
      integer :: i,j,k,kk,jj
      integer :: i_b, i_e, j_b, j_e, k_b, k_e
      real, dimension(i_b:i_e,j_b:j_e,k_b:k_e) :: dcrj

      do kk= k_b,k_e,kblock
      do jj= j_b,j_e,jblock
      do 20 k= kk,min(kk+kblock-1,k_e)
      do 20 j= jj,min(jj+jblock-1,j_e)

      u1(i_b:i_e,j,k) = u1(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      v1(i_b:i_e,j,k) = v1(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)
      w1(i_b:i_e,j,k) = w1(i_b:i_e,j,k)*dcrj(i_b:i_e,j,k)

   20 continue
      end do
      end do

      return
      end


c
c program target
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxsamp=25000)
      integer*2 obufr(maxsamp),obufg(maxsamp),obufb(maxsamp)
      integer*4 unit(3),status,count,def,samp,dn,target

c parameters
      call xvpcnt('OUT',nods)
      call xvparm('CYCLE',cycle,count,def,1)
      call xvparm('NL',nl,count,def,1)
      call xvparm('NS',ns,count,def,1)
      call xvparm('TARGET',target,count,def,1)
      pi=3.141592654

c open outputs
      nli=nl/2
      nsi=ns/2
      nl=nli*2
      ns=nsi*2
      do image=1,nods
        call xvunit(unit(image),'OUT',image,status,' ')
        call xvopen(unit(image),status,'U_FORMAT','HALF',
     +              'U_NL',nl,'U_NS',ns,'OP','WRITE',
     +              'O_FORMAT','BYTE',' ')
      enddo

      if(target.gt.1)goto 10

c radial spoke target
      alias=(cycle/pi)**2
      do line=1,nli
        y=line-(nli+1)/2
        do samp=1,nsi
          x=samp-(nsi+1)/2
          r=x*x+y*y
          if(r.gt.alias)then
            theta=atan2(y,x)
            dn=nint(127.*cos(theta*cycle)+127.)
            obufr(samp)=dn
            obufr(samp+nsi)=dn
            obufg(samp)=dn
            obufg(samp+nsi)=0
            obufb(samp)=dn
            obufb(samp+nsi)=0
          else
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=0
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=0
          endif
        enddo
        if(nods.ge.1)
     +    call xvwrit(unit(1),obufr,status,' ')
        if(nods.ge.2)
     +    call xvwrit(unit(2),obufg,status,' ')
        if(nods.ge.3)
     +    call xvwrit(unit(3),obufb,status,' ')
      enddo
      do line=1,nli
        y=line-(nli+1)/2
        do samp=1,nsi
          x=samp-(nsi+1)/2
          r=x*x+y*y
          if(r.gt.alias)then
            theta=atan2(y,x)
            dn=nint(127.*cos(theta*cycle)+127.)
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=dn
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=dn
          else
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=0
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=0
          endif
        enddo
        if(nods.ge.1)
     +    call xvwrit(unit(1),obufr,status,' ')
        if(nods.ge.2)
     +    call xvwrit(unit(2),obufg,status,' ')
        if(nods.ge.3)
     +    call xvwrit(unit(3),obufb,status,' ')
      enddo
      goto 20

c radial frequency target
10    alias=max((nli+1)/2,(nsi+1)/2)
      do line=1,nli
        y=line-(nli+1)/2
        do samp=1,nsi
          x=samp-(nsi+1)/2
          r=sqrt(x*x+y*y)
          if(r.eq.0.0)r=.00001
          if(r.lt.alias)then
            wavelength=2.0*alias/r
            dn=nint(127.*cos(r*pi/wavelength)+127.)
            obufr(samp)=dn
            obufr(samp+nsi)=dn
            obufg(samp)=dn
            obufg(samp+nsi)=0
            obufb(samp)=dn
            obufb(samp+nsi)=0
          else
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=0
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=0
          endif
        enddo
        if(nods.ge.1)
     +    call xvwrit(unit(1),obufr,status,' ')
        if(nods.ge.2)
     +    call xvwrit(unit(2),obufg,status,' ')
        if(nods.ge.3)
     +    call xvwrit(unit(3),obufb,status,' ')
      enddo
      do line=1,nli
        y=line-(nli+1)/2
        do samp=1,nsi
          x=samp-(nsi+1)/2
          r=sqrt(x*x+y*y)
          if(r.eq.0.0)r=.00001
          if(r.lt.alias)then
            wavelength=2.0*alias/r
            dn=nint(127.*cos(r*pi/wavelength)+127.)
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=dn
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=dn
          else
            obufr(samp)=0
            obufr(samp+nsi)=0
            obufg(samp)=0
            obufg(samp+nsi)=0
            obufb(samp)=0
            obufb(samp+nsi)=0
          endif
        enddo
        if(nods.ge.1)
     +    call xvwrit(unit(1),obufr,status,' ')
        if(nods.ge.2)
     +    call xvwrit(unit(2),obufg,status,' ')
        if(nods.ge.3)
     +    call xvwrit(unit(3),obufb,status,' ')
      enddo

20    return
      end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine jacobi  --  jacobi matrix diagonalization  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "jacobi" performs a matrix diagonalization of a real
c     symmetric matrix by the method of Jacobi rotations
c
c     variables and parameters:
c
c     n     dimension of the matrix to be diagonalized
c     a     input with the matrix to be diagonalized; only
c              the upper triangle and diagonal are required
c     d     returned with the eigenvalues in ascending order
c     v     returned with the eigenvectors of the matrix
c     b     temporary work vector
c     z     temporary work vector
c
c
      subroutine jacobi (n,a,d,v)
      implicit none
      include 'iounit.i'
      integer i,j,k
      integer n,ip,iq
      integer nrot,maxrot
      real*8 sm,tresh,s,c,t
      real*8 theta,tau,h,g,p
      real*8 d(*)
      real*8, allocatable :: b(:)
      real*8, allocatable :: z(:)
      real*8 a(n,*)
      real*8 v(n,*)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (b(n))
      allocate (z(n))
c
c     setup and initialization
c
      maxrot = 100
      nrot = 0
      do ip = 1, n
         do iq = 1, n
            v(ip,iq) = 0.0d0
         end do
         v(ip,ip) = 1.0d0
      end do
      do ip = 1, n
         b(ip) = a(ip,ip)
         d(ip) = b(ip)
         z(ip) = 0.0d0
      end do
c
c     perform the jacobi rotations
c
      do i = 1, maxrot
         sm = 0.0d0
         do ip = 1, n-1
            do iq = ip+1, n
               sm = sm + abs(a(ip,iq))
            end do
         end do
         if (sm .eq. 0.0d0)  goto 10
         if (i .lt. 4) then
            tresh = 0.2d0*sm / n**2
         else
            tresh = 0.0d0
         end if
         do ip = 1, n-1
            do iq = ip+1, n
               g = 100.0d0 * abs(a(ip,iq))
               if (i.gt.4 .and. abs(d(ip))+g.eq.abs(d(ip))
     &                    .and. abs(d(iq))+g.eq.abs(d(iq))) then
                  a(ip,iq) = 0.0d0
               else if (abs(a(ip,iq)) .gt. tresh) then
                  h = d(iq) - d(ip)
                  if (abs(h)+g .eq. abs(h)) then
                     t = a(ip,iq) / h
                  else
                     theta = 0.5d0*h / a(ip,iq)
                     t = 1.0d0 / (abs(theta)+sqrt(1.0d0+theta**2))
                     if (theta .lt. 0.0d0)  t = -t
                  end if
                  c = 1.0d0 / sqrt(1.0d0+t**2)
                  s = t * c
                  tau = s / (1.0d0+c)
                  h = t * a(ip,iq)
                  z(ip) = z(ip) - h
                  z(iq) = z(iq) + h
                  d(ip) = d(ip) - h
                  d(iq) = d(iq) + h
                  a(ip,iq) = 0.0d0
                  do j = 1, ip-1
                     g = a(j,ip)
                     h = a(j,iq)
                     a(j,ip) = g - s*(h+g*tau)
                     a(j,iq) = h + s*(g-h*tau)
                  end do
                  do j = ip+1, iq-1
                     g = a(ip,j)
                     h = a(j,iq)
                     a(ip,j) = g - s*(h+g*tau)
                     a(j,iq) = h + s*(g-h*tau)
                  end do
                  do j = iq+1, n
                     g = a(ip,j)
                     h = a(iq,j)
                     a(ip,j) = g - s*(h+g*tau)
                     a(iq,j) = h + s*(g-h*tau)
                  end do
                  do j = 1, n
                     g = v(j,ip)
                     h = v(j,iq)
                     v(j,ip) = g - s*(h+g*tau)
                     v(j,iq) = h + s*(g-h*tau)
                  end do
                  nrot = nrot + 1
               end if
            end do
         end do
         do ip = 1, n
            b(ip) = b(ip) + z(ip)
            d(ip) = b(ip)
            z(ip) = 0.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (b)
      deallocate (z)
c
c     print warning if not converged
c
   10 continue
      if (nrot .eq. maxrot) then
         write (iout,20)
   20    format (/,' JACOBI  --  Matrix Diagonalization not Converged')
      end if
c
c     sort the eigenvalues and vectors
c
      do i = 1, n-1
         k = i
         p = d(i)
         do j = i+1, n
            if (d(j) .lt. p) then
               k = j
               p = d(j)
            end if
         end do
         if (k .ne. i) then
            d(k) = d(i)
            d(i) = p
            do j = 1, n
               p = v(j,i)
               v(j,i) = v(j,k)
               v(j,k) = p
            end do
         end if
      end do
      return
      end


C++------------------------------------------------------------------
C Program CALIBPDS2
C to transform densities into intensities.
C To be used after CALIBPDS1
C
C JLP  Version of 15-12-86
C--------------------------------------------------------------------
	PROGRAM CALIBPDS2
	PARAMETER (IDIM=600)
	REAL*8 XC(30),TEST,XX1,YY1
	REAL*4 XX,YY
	REAL*4 INPUT(IDIM,IDIM),OUTPUT(IDIM,IDIM)
	CHARACTER ANS*1,NAME*40,COMMENTS*80

10	FORMAT(A)

C Inquire the format of the files :
	CALL JLP_INQUIFMT

C Entering the image :
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
	CALL JLP_READIMAG(INPUT,NX1,NY1,IDIM,NAME,COMMENTS)
	PRINT *,' SKY LEVEL USED IN CALIBPDS1 FOR THE FIT :'
	READ(5,*) SKY

C To avoid too large exponents (10**YY ...) :
	PRINT *,' LOWER AND UPPER THRESHOLDS FOR THE CONVERSION'
	PRINT *,'   ( IN LOG10(DENSITY) ) :'
	READ(5,*) XLOW,XHIGH

C Entering the coefficients of the polynomial (increasing degree) :
	PRINT *,' DEGREE OF THE POLYNOMIAL (IN LOG10/LOG10):'
	READ(5,*) KDEGREE

	DO IK=1,KDEGREE+1
	PRINT 100,IK
100	FORMAT(' XC(',I3,') = ',$)
	READ(5,*) XC(IK)
	END DO

C Number of pixels with values less than the sky level :
	TEST=0.

C Main loop :
	DO J=1,NY1
	DO I=1,NX1
	X=INPUT(I,J)-SKY
	  IF(X.GT.0.)THEN
	  XX=ALOG10(X)
	    IF(XX.GT.XLOW.AND.XX.LT.XHIGH)THEN
	    XX1=XX
	    CALL CALPOLY(XX1,YY1,XC,KDEGREE)
	    YY=YY1
	    OUTPUT(I,J)=10**YY
	    ELSE
	    OUTPUT(I,J)=0.
	    ENDIF
	  ELSE
	  TEST=TEST+1.
	  OUTPUT(I,J)=0.
	  ENDIF
	END DO
	END DO

	IF(TEST.NE.0.)PRINT 203,TEST
203	FORMAT(' WARNING :',E12.4,' NEGATIVE VALUES !')

C Output of the image :
        WRITE(6,*) 'Output file: '
        READ(5,10) NAME
	CALL JLP_WRITEIMAG(OUTPUT,NX1,NY1,IDIM,NAME,COMMENTS)

	STOP
	END
C------------------------------------------------------------------------
	include 'jlpsub:polyfit.for'


program main
	implicit none
	integer :: year
	integer :: day = 365

	write (*,'(A)') 'Please input the year you want to konw :'
	read  (*,*) year
	if ((mod(year, 4) == 0) .and. ((mod(year, 100) == 0) .and. (mod(year, 400) == 0))) then
		day = day + 1
	end if
	write (*,'(A,I0,A,I0,A)') 'Year', year, ' has ', day, 'days.'
	pause
end program main


module SomeModule
   implicit none
 contains
    elemental function A(x) result(res)
        integer :: res
        integer, intent(IN) :: x
        res = x + 1
    end function
end module SomeModule

program Test
   use SomeModule, DoSomething => A
   implicit none

   !Declare variables
   integer, parameter :: m = 3, n = 3
   integer, pointer :: p(:)=>null(), q(:,:)=>null()
   integer, allocatable, target :: A(:,:)
   integer :: istat = 0, i, j
   character(80) :: fmt

!  Write format string for matrices
!  (/ A / A, " = [", 3( "[",3(i2, 1x), "]" / 5x), "]" )
   write (fmt, '("(/ A / A, "" = ["", ", i0, "( ""["",", i0, "(i2, 1x), ""]"" / 5x), ""]"" )")') m, n

   allocate(A(m, n), q(m, n), stat = istat)
   if (istat /= 0) stop 'Error during allocation of A and q'

!  Matrix A is:
!  A = [[ 1  4  7 ]
!       [ 2  5  8 ]
!       [ 3  6  9 ]
!       ]
   A = reshape([(i, i = 1, size(A))], shape(A))
   q = A

   write(*, fmt) "Matrix A is:", "A", ((A(i, j), j = 1, size(A, 2)), i = 1, size(A, 1))

!  p will be associated with the first column of A
   p => A(:, 1)

!  This operation on p has a direct effect on matrix A
   p = p ** 2

!  This will end the association between p and the first column of A
   nullify(p)

!  Matrix A becomes:
!  A = [[ 1  4  7 ]
!       [ 4  5  8 ]
!       [ 9  6  9 ]
!       ]
   write(*, fmt) "Matrix A becomes:", "A", ((A(i, j), j = 1, size(A, 2)), i = 1, size(A, 1))

!  Perform some array operation
   q = q + A

!  Matrix q becomes:
!  q = [[ 2  8 14 ]
!       [ 6 10 16 ]
!       [12 12 18 ]
!       ]
   write(*, fmt) "Matrix q becomes:", "q", ((q(i, j), j = 1, size(A, 2)), i = 1, size(A, 1))

!  Use p as an ordinary array
   allocate (p(1:m*n), stat = istat)
   if (istat /= 0) stop 'Error during allocation of p'

!  Perform some array operation
   p = reshape(DoSomething(A + A ** 2), shape(p))

!  Array operation:
!      p(1) = 3
!      p(2) = 21
!      p(3) = 91
!      p(4) = 21
!      p(5) = 31
!      p(6) = 43
!      p(7) = 57
!      p(8) = 73
!      p(9) = 91
   write(*, '("Array operation:" / (4x,"p(",i0,") = ",i0))') (i, p(i), i = 1, size(p))

   deallocate(A, p, q, stat = istat)
   if (istat /= 0) stop 'Error during deallocation'

end program Test


program bench_inline
use gpfunc, only: build_K, build_K_sqexp, build_K_vec, kern_sqexp_vec, &
    kern_sqexp_elem, build_K_sqexp_T, build_K_vec_T, kern_sqexp_vec_T, &
    build_K_der, Kernel, CompositeKernel, kern_sqexp_1D, build_K_prod, &
    build_K_interface, SqExpGP, kern_one_1D
implicit none

integer, parameter :: np = 4096
integer, parameter :: ndim = 3

real(8), allocatable :: x(:, :), xT(:,:)
real(8), allocatable :: K(:, :)
integer :: kn, kd
integer(8) :: count, count_rate, count_max
real(8) :: tic, toc

type(Kernel) :: kern_holder
type(CompositeKernel) :: prod_kern
type(SqExpGP) :: sqexp_gp

integer(8) :: kk

! real(8), external :: kern_sqexp

allocate(K(np, np), x(np, ndim), xT(ndim, np))

do kn = 1, np
    do kd = 1, ndim
        call random_number(x(kn, kd))
    end do
end do

xT = transpose(x)

!-------------------------------------------------------------------------------
! Element-wise kernel
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K(np, ndim, xT, xT, K, kern_sqexp_elem)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Element-wise kernel
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K(np, ndim, xT, xT, K, kern_sqexp_elem)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Element-wise kernel with interface
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K_interface(np, ndim, xT, xT, K, kern_sqexp_elem)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_interface:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Element-wise kernel with polymorphism
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call sqexp_gp%build_K_poly(np, ndim, xT, xT, K)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_poly:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Row-wise kernel
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K_vec(np, ndim, x, x, K, kern_sqexp_vec)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_vec:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Inline in loop
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K_sqexp(np, ndim, x, x, K)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_sqexp:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Inline in loop array of structs
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K_sqexp_T(np, ndim, xT, xT, K)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_sqexp_T:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Row-wise array of structs
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

call build_K_vec_T(np, ndim, xT, xT, K, kern_sqexp_vec_T)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_vec_T:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Row-wise kernel with derived type and function pointer
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

kern_holder%kern => kern_sqexp_vec

call build_K_der(np, ndim, x, x, K, kern_holder)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_vec_der:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

!-------------------------------------------------------------------------------
! Product kernel with derived type and function pointer
K = 0d0
call system_clock(count, count_rate, count_max)
tic = count*1d3/count_rate

allocate(prod_kern%kernels(ndim))
prod_kern%kernels(1)%kern => kern_one_1D
do kk = 2, ndim
    prod_kern%kernels(kk)%kern => kern_sqexp_1D
end do

call build_K_prod(np, ndim, x, x, K, prod_kern)

call system_clock(count, count_rate, count_max)
toc = count*1d3/count_rate
print *, 'Time build_K_prod:', toc - tic, 'ms'
print *, K(5,5), K(np,np-5)
print *, ''

deallocate(prod_kern%kernels)
deallocate(K, x)

end program bench_inline


      subroutine sphere_basis_complete(x,y, t, tinv,tderivs, flag)
      implicit none

      double precision x,y
      integer flag
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)

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

      double precision f(3), fx(3), fy(3), fxx(3), fyy(3), fxy(3)
      double precision g(3), gx(3), gy(3), gxx(3), gyy(3), gxy(3)

      integer k, i
      logical compute_covariant, compute_contravariant
      logical compute_derivatives, b(32)

      double precision theta, thetax, thetay
      double precision phi, phix, phiy

      if (flag > 7) then
          write(6,*) 'sphere_basis.f : flag > 7'
          stop
      endif

c     # flag = 0      NA
c     # flag = 1      Covariant basis only
c     # flag = 2      NA
c     # flag = 3      Covariant + contravariant basis
c     # flag = 4      Derivatives only
c     # flag = 5      Derivatives + covariant basis
c     # flag = 6      NA
c     # flag = 7      Covariant + contravariant + derivatives

      do i = 1,bit_size(flag)
          b(i) = btest(flag,i-1)
      enddo

      compute_covariant     = b(1) .or. b(2)
      compute_contravariant = b(2)
      compute_derivatives   = b(3)

c     # ---------------------------
c     # Spherical coordinates
c     # ---------------------------
c         xp = cos(phi)*cos(theta)
c         yp = cos(phi)*sin(theta)
c         zp = sin(phi)
c     # ---------------------------

      call map_comp2spherical_derivs(x,y,theta,phi,
     &                     thetax, thetay, phix, phiy)

c     # Express T(x,y) = g(y)*f(x)
c     #
c     #    T1(x,y) = g1(y)*f1(x)
c     #    T2(x,y) = g2(y)*f2(x)
c     #    T3(x,y) = g3(y)*f3(x)
c     #

      f(1)  = cos(theta)
      f(2)  = sin(theta)
      f(3) = 1

      fx(1) = -thetax*sin(theta)
      fx(2) = thetax*cos(theta)
      fx(3) = 0

      fy(1) = 0
      fy(2) = 0
      fy(3) = 0

      g(1) = cos(phi)
      g(2) = cos(phi)
      g(3) = sin(phi)

      gx(1) = 0
      gx(2) = 0
      gx(3) = 0

      gy(1) = -phiy*sin(phi)
      gy(2) = -phiy*sin(phi)
      gy(3) = phiy*cos(phi)

      if (compute_covariant) then
          do k = 1,3
              t(k,1) = gx(k)*f(k) + g(k)*fx(k);
              t(k,2) = gy(k)*f(k) + g(k)*fy(k);
          enddo
      endif

      if (compute_contravariant) then
          call map_contravariant(t,tinv)
      endif

      if (compute_derivatives) then
          fxx(1) = -thetax**2*cos(theta)
          fxx(2) = -thetax**2*sin(theta)
          fxx(3) = 0

          fyy(1) = 0
          fyy(2) = 0
          fyy(3) = 0

          fxy(1) = 0
          fxy(2) = 0
          fxy(3) = 0

          gxx(1) = 0
          gxx(2) = 0
          gxx(3) = 0

          gyy(1) = -phiy**2*cos(phi)
          gyy(2) = -phiy**2*cos(phi)
          gyy(3) = 0

          gxy(1) = 0
          gxy(2) = 0
          gxy(3) = 0

          do k = 1,3
c             # d(t1)/dx = d(g*fx + gx*f)/dx
              tderivs(k,1,1) = g(k)*fxx(k) +
     &                     2*fx(k)*gx(k) + gxx(k)*f(k)

c             # d(t1)/dy = d(g*fx + gx*f)/dy
              tderivs(k,1,2) = g(k)*fxy(k) + gy(k)*fx(k) +
     &                    gx(k)*fy(k) + gxy(k)*f(k)

c             # d(t2)/dx = d(g*fy + gy*f)/dx
              tderivs(k,2,1) = g(k)*fxy(k) + gx(k)*fy(k) +
     &                    gy(k)*fx(k) + gxy(k)*f(k)

c             # d(t2)/dy = d(g*fy + gy*f)/dy
              tderivs(k,2,2) = g(k)*fyy(k) +
     &                    2*fy(k)*gy(k) + gyy(k)*f(k)
          enddo
      endif

      end

      subroutine mapc2m_spherical(xc,yc,xp,yp,zp)
      implicit none

      double precision xc,yc,xp,yp,zp
      double precision phi, theta

c     # Map computational coordinates in [0,1]x[0,1]
c     # to physical coordinates

      call map_comp2spherical(xc,yc,theta,phi)

      xp = cos(phi)*cos(theta)
      yp = cos(phi)*sin(theta)
      zp = sin(phi)

      end

      subroutine map_comp2spherical(xc,yc,theta,phi)
      implicit none

      double precision xc,yc,theta, thetax, thetay
      double precision phi, phix, phiy

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

c     # Map xc in [0,1] to theta in [-pi,pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      call map_comp2spherical_derivs(xc,yc,theta,phi,
     &               thetax, thetay, phix, phiy)

      end

      subroutine map_comp2spherical_derivs(xc,yc,theta,phi,
     &      thetax, thetay, phix, phiy)
      implicit none

      double precision xc,yc,theta, thetax, thetay
      double precision phi, phix, phiy

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

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      theta = pi2*xc
      thetax = pi2
      thetay= 0

c      phi = -pi/2.d0 + pi*yc
      phi = (yc - 0.5)*pi
      phix = 0
      phiy = pi

      end

      subroutine map_spherical2comp(theta,phi,xc,yc)
      implicit none

      double precision xc,yc,phi,theta

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

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      xc = theta/pi2
      yc = (phi + pi/2.d0)/pi

      end

      subroutine map2spherical(xp,yp,zp,theta,phi)
      implicit none

      double precision xp,yp,zp,phi,theta

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

      phi = asin(zp)          !! returns value in [-pi/2, pi/2]
      theta = atan2(yp,xp)    !! returns value in [-pi, pi]
      if (theta < 0) then
          theta = theta + pi2
      endif

      end

      subroutine user_map2comp(blockno,xc,yc,xp,yp,zp,xc1,yc1)
      implicit none

      integer blockno
      double precision xc,yc, xp,yp,zp, xc1,yc1

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

      double precision phi, theta

      call map2spherical(xp,yp,zp,theta,phi)

      call map_spherical2comp(theta,phi,xc1,yc1)

      end


program main
  use adjac

  integer, parameter :: blocksize = 128, n = blocksize*1000, filliter = 3

  double precision :: xval(n), yval(n)
  double precision, allocatable, dimension(:) :: jac_val
  integer, allocatable, dimension(:) :: jac_i, jac_j
  integer :: rep, i

  do i = 1, n
     xval(i) = 1d0 + i
  end do

  do rep = 1, 5
     if (rep > 1) then
        deallocate(jac_val, jac_i, jac_j)
     end if
     call doit(xval, yval, jac_val, jac_i, jac_j)
  end do

  write(*,*) 'nnz =', size(jac_val)
  write(*,*) 'sparsity =', (size(jac_val)*1d0)/(1d0*n)/(1d0*n)
  write(*,*) jac_val(1:5)
  write(*,*) jac_i(1:5)
  write(*,*) jac_j(1:5)

contains
  subroutine doit(xval, yval, jac_val, jac_i, jac_j)
    implicit none
    double precision, intent(in) :: xval(n)
    double precision, intent(out) :: yval(n)
    type(adjac_double) :: x(n), y(n)
    double precision, allocatable, dimension(:), intent(inout) :: jac_val
    integer, allocatable, dimension(:), intent(inout) :: jac_i, jac_j
    integer :: nnz

    call adjac_reset()
    call adjac_set_independent(x, xval)
    call oper(x, y)

    call adjac_get_value(y, yval)
    call adjac_get_coo_jacobian(y, nnz, jac_val, jac_i, jac_j)
  end subroutine doit

  subroutine oper(x, y)
    implicit none
    type(adjac_double), dimension(n), intent(in) :: x
    type(adjac_double), dimension(n), intent(out) :: y
    integer :: i, k, p

    y(1) = -2*x(1) + x(2)
    y(n) = -2*x(n) + x(n-1)
    do i = 2, n-1
       y(i) = x(i+1) - 2*x(i) + x(i-1)
    end do

    do k = 1, n, blocksize
       do p = 1, filliter
          do i = k+1, k + blocksize-1
             y(i) = y(i-1) - 2*y(i) + y(i+1)/(3.1415d0 + y(i))
          end do
       end do
    end do
  end subroutine oper
end program main


cc Copyright (C) 2010-2011: Leslie Greengard, Zydrunas Gimbustas
cc and Manas Rachh
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.

c
c   Laplace FMM in R^2: evaluate all pairwise particle
c   interactions (ignoring self-interaction)
c   and interactions with targets.
c
c   We use log(r) for the Green's function.
c   Self-interactions are not included
c
c   l2d: charge and dipstr are complex valued, x in \R^2
c
c   \phi(x_i) = \sum_{j\ne i} charge_j log|x_i-x_j}
c   + dipstr_j/x_i - x_j
c
c

      subroutine cfmm2d_s_c_p(eps,ns,sources,
     1            charge,pot,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge
cf2py  intent(out) pot,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns)

      complex *16 pot(ns)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1     ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2     nt,targ,ifpghtarg,pottarg,gradtarg,
     3     hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_s_c_g(eps,ns,sources,
     1            charge,pot,grad,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge
cf2py  intent(out) pot,grad,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns)
      complex *16 pot(ns),grad(ns)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_s_c_h(eps,ns,sources,
     1            charge,pot,grad,hess,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge
cf2py  intent(out) pot,grad,hess,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   hess(ns)      : hessian at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns)
      complex *16 pot(ns),grad(ns),hess(ns)

c
cc     temporary variables
c
      complex *16 dipstr
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1),hesstarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_s_d_p(eps,ns,sources,
     1            dipstr,pot,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr
cf2py  intent(out) pot,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 dipstr(ns)

      complex *16 pot(ns)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_s_d_g(eps,ns,sources,
     1            dipstr,pot,grad,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr
cf2py  intent(out) pot,grad,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)    : gradients at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 dipstr(ns)
      complex *16 pot(ns),grad(ns)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_s_d_h(eps,ns,sources,
     1            dipstr,pot,grad,hess,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr
cf2py  intent(out) pot,grad,hess,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)    : gradients at the source locations
c   hess(ns)    : hessian at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 dipstr(ns)
      complex *16 pot(ns),grad(ns),hess(ns)

c
cc     temporary variables
c
      complex *16 charge
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1),hesstarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_s_cd_p(eps,ns,sources,charge,
     1            dipstr,pot,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr
cf2py  intent(out) pot,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns)

c
cc     temporary variables
c
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_s_cd_g(eps,ns,sources,charge,
     1            dipstr,pot,grad,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr
cf2py  intent(out) pot,grad,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)    : gradients at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns),grad(ns)

c
cc     temporary variables
c
      complex *16 hess,hesstarg
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_s_cd_h(eps,ns,sources,charge,
     1            dipstr,pot,grad,hess,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr
cf2py  intent(out) pot,grad,hess,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)    : gradients at the source locations
c   hess(ns)    : hessian at the source locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,ier
      real *8 sources(2,ns)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns),grad(ns),hess(ns)

c
cc     temporary variables
c
      real *8 targ(2)
      complex *16 pottarg(1),gradtarg(1),hesstarg(1)
      integer nt
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 0

      nt = 0

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

c----------------------------------------------
c
c
c
      subroutine cfmm2d_t_c_p(eps,ns,sources,
     1            charge,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)

      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      complex *16 pot(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1     ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2     nt,targ,ifpghtarg,pottarg,gradtarg,
     3     hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_t_c_g(eps,ns,sources,
     1            charge,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)     : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 hess,hesstarg
      complex *16 pot(1),grad(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_t_c_h(eps,ns,sources,
     1            charge,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)     : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 pot(1),grad(1),hess(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 0
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_t_d_p(eps,ns,sources,
     1            dipstr,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)

      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      complex *16 pot(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_t_d_g(eps,ns,sources,
     1            dipstr,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 hess,hesstarg
      complex *16 pot(1),grad(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_t_d_h(eps,ns,sources,
     1            dipstr,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 pot(1),grad(1),hess(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_t_cd_p(eps,ns,sources,charge,
     1            dipstr,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      complex *16 pot(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_t_cd_g(eps,ns,sources,charge,
     1            dipstr,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 hess,hesstarg
      complex *16 pot(1),grad(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_t_cd_h(eps,ns,sources,charge,
     1            dipstr,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      complex *16 pot(1),grad(1),hess(1)
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 0
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

c----------------------------------------------
c
c
c
      subroutine cfmm2d_st_c_p(eps,ns,sources,
     1            charge,pot,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pot,pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)

      complex *16 pot(ns)
      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 1
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1     ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2     nt,targ,ifpghtarg,pottarg,gradtarg,
     3     hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_st_c_g(eps,ns,sources,
     1            charge,pot,grad,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pot,grad,pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)
      complex *16 pot(ns),grad(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 2
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_st_c_h(eps,ns,sources,
     1            charge,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,nt,targ
cf2py  intent(out) pot,grad,hess,pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   hess(ns)      : hessian at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns)
      complex *16 pot(ns),grad(ns),hess(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      complex *16 dipstr
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 0

      ifpgh = 3
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_st_d_p(eps,ns,sources,
     1            dipstr,pot,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pot,pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)

      complex *16 pot(ns)
      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_st_d_g(eps,ns,sources,
     1            dipstr,pot,grad,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pot,grad,pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c     nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)
      complex *16 pot(ns),grad(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_st_d_h(eps,ns,sources,
     1            dipstr,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,dipstr,nt,targ
cf2py  intent(out) pot,grad,hess,pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   hess(ns)      : hessian at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 dipstr(ns)
      complex *16 pot(ns),grad(ns),hess(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      complex *16 charge
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 0
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end

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

      subroutine cfmm2d_st_cd_p(eps,ns,sources,charge,
     1            dipstr,pot,nt,targ,pottarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pot,pottarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   pottarg(nt)   : potential at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns)
      complex *16 pottarg(nt)

c
cc     temporary variables
c
      complex *16 grad,gradtarg
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg

      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 1
      ifpghtarg = 1

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------

      subroutine cfmm2d_st_cd_g(eps,ns,sources,charge,
     1            dipstr,pot,grad,nt,targ,pottarg,gradtarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pot,grad,pottarg,gradtarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns),grad(ns)
      complex *16 pottarg(nt),gradtarg(nt)

c
cc     temporary variables
c
      complex *16 hess,hesstarg
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 2
      ifpghtarg = 2

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end
c------------------------------
c
c
c
c
c
      subroutine cfmm2d_st_cd_h(eps,ns,sources,charge,
     1            dipstr,pot,grad,hess,nt,targ,pottarg,
     2            gradtarg,hesstarg,ier)
cf2py  intent(in) eps
cf2py  intent(in) ns,sources,charge,dipstr,nt,targ
cf2py  intent(out) pot,grad,hess,pottarg,gradtarg,hesstarg,ier
c----------------------------------------------
c   INPUT PARAMETERS:
c   eps           : FMM precision requested
c   ns            : number of sources
c   sources(2,ns) : source locations
c   charge(ns)    : charge strengths
c   dipstr(ns)    : dipole strengths
c   nt            : number of targets
c   targ(2,nt)    : target locations
c
c   OUTPUT PARAMETERS
c   pot(ns)       : potential at the source locations
c   grad(ns)      : gradients at the source locations
c   hess(ns)      : hessian at the source locations
c   pottarg(nt)   : potential at the target locations
c   gradtarg(nt)  : gradient at the target locations
c   hesstarg(nt)  : hessian at the target locations
c

      implicit none
c
cc      calling sequence variables
c
      real *8 eps
      integer ns,nt,ier
      real *8 sources(2,ns),targ(2,nt)
      complex *16 charge(ns),dipstr(ns)
      complex *16 pot(ns),grad(ns),hess(ns)
      complex *16 pottarg(nt),gradtarg(nt),hesstarg(nt)

c
cc     temporary variables
c
      integer ifcharge,ifdipole
      integer ifpgh,ifpghtarg
      integer nd,iper

      ifcharge = 1
      ifdipole = 1

      ifpgh = 3
      ifpghtarg = 3

      nd = 1

      call cfmm2d(nd,eps,ns,sources,ifcharge,charge,
     1            ifdipole,dipstr,iper,ifpgh,pot,grad,hess,
     2            nt,targ,ifpghtarg,pottarg,gradtarg,
     3            hesstarg)
      return
      end


*> \brief \b DGTT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK,
*                          LDWORK, RWORK, RESID )
*
*       .. Scalar Arguments ..
*       INTEGER            LDWORK, N
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
*      $                   DU2( * ), DUF( * ), RWORK( * ),
*      $                   WORK( LDWORK, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGTT01 reconstructs a tridiagonal matrix A from its LU factorization
*> and computes the residual
*>    norm(L*U - A) / ( norm(A) * EPS ),
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGTER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*>          DL is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) sub-diagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*>          DU is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) super-diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DLF
*> \verbatim
*>          DLF is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) multipliers that define the matrix L from the
*>          LU factorization of A.
*> \endverbatim
*>
*> \param[in] DF
*> \verbatim
*>          DF is DOUBLE PRECISION array, dimension (N)
*>          The n diagonal elements of the upper triangular matrix U from
*>          the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DUF
*> \verbatim
*>          DUF is DOUBLE PRECISION array, dimension (N-1)
*>          The (n-1) elements of the first super-diagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*>          DU2 is DOUBLE PRECISION array, dimension (N-2)
*>          The (n-2) elements of the second super-diagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices; for 1 <= i <= n, row i of the matrix was
*>          interchanged with row IPIV(i).  IPIV(i) will always be either
*>          i or i+1; IPIV(i) = i indicates a row interchange was not
*>          required.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (LDWORK,N)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*>          LDWORK is INTEGER
*>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          The scaled residual:  norm(L*U - A) / (norm(A) * EPS)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE DGTT01( N, DL, D, DU, DLF, DF, DUF, DU2, IPIV, WORK,
     $                   LDWORK, RWORK, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            LDWORK, N
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
     $                   DU2( * ), DUF( * ), RWORK( * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IP, J, LASTJ
      DOUBLE PRECISION   ANORM, EPS, LI
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGT, DLANHS
      EXTERNAL           DLAMCH, DLANGT, DLANHS
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DSWAP
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
      EPS = DLAMCH( 'Epsilon' )
*
*     Copy the matrix U to WORK.
*
      DO 20 J = 1, N
         DO 10 I = 1, N
            WORK( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
      DO 30 I = 1, N
         IF( I.EQ.1 ) THEN
            WORK( I, I ) = DF( I )
            IF( N.GE.2 )
     $         WORK( I, I+1 ) = DUF( I )
            IF( N.GE.3 )
     $         WORK( I, I+2 ) = DU2( I )
         ELSE IF( I.EQ.N ) THEN
            WORK( I, I ) = DF( I )
         ELSE
            WORK( I, I ) = DF( I )
            WORK( I, I+1 ) = DUF( I )
            IF( I.LT.N-1 )
     $         WORK( I, I+2 ) = DU2( I )
         END IF
   30 CONTINUE
*
*     Multiply on the left by L.
*
      LASTJ = N
      DO 40 I = N - 1, 1, -1
         LI = DLF( I )
         CALL DAXPY( LASTJ-I+1, LI, WORK( I, I ), LDWORK,
     $               WORK( I+1, I ), LDWORK )
         IP = IPIV( I )
         IF( IP.EQ.I ) THEN
            LASTJ = MIN( I+2, N )
         ELSE
            CALL DSWAP( LASTJ-I+1, WORK( I, I ), LDWORK, WORK( I+1, I ),
     $                  LDWORK )
         END IF
   40 CONTINUE
*
*     Subtract the matrix A.
*
      WORK( 1, 1 ) = WORK( 1, 1 ) - D( 1 )
      IF( N.GT.1 ) THEN
         WORK( 1, 2 ) = WORK( 1, 2 ) - DU( 1 )
         WORK( N, N-1 ) = WORK( N, N-1 ) - DL( N-1 )
         WORK( N, N ) = WORK( N, N ) - D( N )
         DO 50 I = 2, N - 1
            WORK( I, I-1 ) = WORK( I, I-1 ) - DL( I-1 )
            WORK( I, I ) = WORK( I, I ) - D( I )
            WORK( I, I+1 ) = WORK( I, I+1 ) - DU( I )
   50    CONTINUE
      END IF
*
*     Compute the 1-norm of the tridiagonal matrix A.
*
      ANORM = DLANGT( '1', N, DL, D, DU )
*
*     Compute the 1-norm of WORK, which is only guaranteed to be
*     upper Hessenberg.
*
      RESID = DLANHS( '1', N, WORK, LDWORK, RWORK )
*
*     Compute norm(L*U - A) / (norm(A) * EPS)
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         RESID = ( RESID / ANORM ) / EPS
      END IF
*
      RETURN
*
*     End of DGTT01
*
      END


      FUNCTION CLANGE_F95( A, NORM, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!     .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
      USE F77_LAPACK, ONLY: LANGE_F77 => LA_LANGE
!     .. "Implicit Statement" ..
      IMPLICIT NONE
!     .. "Function Type" ..
      REAL(WP) :: CLANGE_F95
!     .. "Scalar Arguments" ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     .. "Array Arguments" ..
      COMPLEX(WP), INTENT(IN) :: A(:,:)
!-----------------------------------------------------------------
!
!  Purpose
!  =======
!
!  LA_LANGE  returns the value of the one norm,  or the Frobenius norm,
!  or the  infinity norm,  or the  element of  largest absolute value
!  of a complex matrix A.
!
!  Description
!  ===========
!
!  LA_LANGE returns the value
!
!     LA_LANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!              (
!              ( norm1(A),         NORM = '1', 'O' or 'o'
!              (
!              ( normI(A),         NORM = 'I' or 'i'
!              (
!              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!
!  where  norm1  denotes the  one norm of a matrix (maximum column sum),
!  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!  normF  denotes the  Frobenius norm of a matrix (square root of sum of
!  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!
!  =========
!
!  FUNCTION LA_ANGE( A, NORM, INFO )
!     REAL(<wp>) :: LA_ANGE
!     <type>(<wp>), INTENT(IN) :: <a>
!     CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: NORM
!     INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     <type> ::= REAL | COMPLEX
!     <wp>   ::= KIND(1.0) | KIND(1.0D0)
!     <a>    ::= A(:,:) | A(:)
!
!  Arguments
!  =========
!
!  A       (input) COMPLEX array, shape either (:,:) or (:).
!          If shape is (:,:) then SIZE(A,1) == m, SIZE(A,2) == n.
!          If shape is (:) then SIZE(A) == n.
!          If either m or n == 0 LA_LANGE is set to zero.
!          The m by n matrix A.
!
!  NORM    (input) CHARACTER*1
!          Specifies the value to be returned in LA_LANGE as described
!          above.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!      If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!
!  ---------------------------------------------------------------------
!     .. "Parameters" ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_LANGE'
!     .. "Local Scalars" ..
      CHARACTER(LEN=1) :: LNORM
      INTEGER :: ISTAT, ISTAT1, LDA, LINFO, M, N
      REAL(WP), TARGET ::LLWORK(1)
!     .. "Local Pointers" ..
      REAL(WP), POINTER :: WORK(:)
!     .. "Intrinsic Functions" ..
      INTRINSIC SIZE, PRESENT, MAX
!     .. "Executable Statements" ..
      LINFO = 0; M = SIZE(A,1); N = SIZE(A,2); LDA = MAX(1,M)
      ISTAT = 0
      IF( PRESENT(NORM) )THEN; LNORM = NORM; ELSE; LNORM = '1'; ENDIF
!     .. "Testing The Arguments" ..
      IF( M < 0 .OR. N < 0 )THEN; LINFO = -1
      ELSE IF( .NOT. ( LSAME(LNORM,'M') .OR. LSAME(LNORM,'1') .OR. &
         LSAME(LNORM,'I') .OR. LSAME(LNORM,'F') .OR. &
         LSAME(LNORM,'E') ) )THEN; LINFO = -2
      ELSE
         IF( LSAME(LNORM,'I') )THEN; ALLOCATE( WORK( M), STAT=ISTAT )
         ELSE; WORK => LLWORK; ENDIF
         IF( ISTAT == 0 ) &
           CLANGE_F95 = LANGE_F77( LNORM, M, N, A, LDA, WORK )
         IF( LSAME(LNORM,'I') )DEALLOCATE( WORK, STAT=ISTAT1 )
      ENDIF
      CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
      END FUNCTION CLANGE_F95


      PROGRAM xfit
C     driver for routine fit
      INTEGER NPT
      REAL SPREAD
      PARAMETER(NPT=100,SPREAD=0.5)
      INTEGER i,idum,mwt
      REAL a,b,chi2,gasdev,q,siga,sigb,sig(NPT),x(NPT),y(NPT)
      idum=-117
      do 11 i=1,NPT
        x(i)=0.1*i
        y(i)=-2.0*x(i)+1.0+SPREAD*gasdev(idum)
        sig(i)=SPREAD
11    continue
      do 12 mwt=0,1
        call fit(x,y,NPT,sig,mwt,a,b,siga,sigb,chi2,q)
        if (mwt.eq.0) then
          write(*,'(//1x,a)') 'Ignoring standard deviation'
        else
          write(*,'(//1x,a)') 'Including standard deviation'
        endif
        write(*,'(1x,t5,a,f9.6,t24,a,f9.6)') 'A = ',a,'Uncertainty: ',
     *       siga
        write(*,'(1x,t5,a,f9.6,t24,a,f9.6)') 'B = ',b,'Uncertainty: ',
     *       sigb
        write(*,'(1x,t5,a,4x,f10.6)') 'Chi-squared: ',chi2
        write(*,'(1x,t5,a,f10.6)') 'Goodness-of-fit: ',q
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfit.for