! *********************************************************************
! ... streamline.f90
! ... Quim Ballabrera, October 2017
! ... COSMO project
! ... Program that calculates the velocity field from a streamfunction.
! ... The output can be in Arakawa's A or C grids.
! ... The velocity field follows:
! ...      u = - dPsi/dy
! ...      v =   dPsi/dx
! ... Version 0.1, released October 2017
! *********************************************************************

use cosmo
use netcdf

implicit none

character(len=*), parameter             :: version = 'v0.1'
character(len=*), parameter             :: author  = 'Quim Ballabrera'

! ... I/O flags and options
! ...
logical                                 :: out   = .false.
logical                                 :: agrid = .false.
logical                                 :: cgrid = .false.
logical                                 :: fdx   = .false.
logical                                 :: fdy   = .false.
logical                                 :: hlp   = .false.
logical                                 :: fscal = .false.

! ...
integer na,nx,ny,i,j,err,fid,idi,idj,idx,idy,idp,idu,idv
integer idxp,idyp,idxu,idyu,idxv,idyv
real(dp)  dx,dy,Uscale
real(dp), dimension(:), allocatable     :: x,y
real(dp), dimension(:), allocatable     :: xu,yu
real(dp), dimension(:), allocatable     :: xv,yv
real(dp), dimension(:,:), allocatable   :: psi,u,v
character(len=180)                      :: ofile

! ... The help
! ...
call help_version(version)
call help_progname('STREAMLINE')
call help_author(author)
call help_summary('Program to calculate the velocity field from an &
 &analytical stream function. The velocity field can be writen in an &
 &Arakawa A or Arakawa C grid. To change the analytic function, the &
 &user needs to modify subroutine UDF before compiling the program.')
call help_option('-out    FILENAME','Output filename','streamline.nc')
call help_option('-A              ','Output in Arakawa A grid','A')
call help_option('-C              ','Output in Arakawa C grid','')
call help_option('-dx             DX','Zonal grid interval','0.1')
call help_option('-dy             DY','Meridional grid interval','0.1')
call help_option('-scale       SCALE','Velocity scale','1.0')
call help_option ('--options  filename','To read the commandline options &
  &from a file.','')
call help_option ('--help','To show this help','')
call help_example ('> streamline -C -o c_grid.nc')

! ... Default values:
! ...
dx = 0.1_dp
dy = 0.1_dp
Uscale = 1.0_dp
ofile = 'streamline.nc'

! ... Lineargs
! ...
call lineargs_ini(na)
if (na.eq.0) call help_write()

call argflg('--h',hlp)
call argflg('-help',hlp)
if (hlp) then
  call help_write()
else
  call header()
endif

call argstr('-o',out,ofile)
call argflg('-A',agrid)
call argflg('-C',cgrid)
call argdbl('-dx',fdx,dx)
call argdbl('-dy',fdy,dy)
call argdbl('-scale',fscal,Uscale)

if (agrid.and.cgrid) call stop_error(1,'Incompatible options -A and -C')
agrid = .not.cgrid

if (agrid) then
  write(*,*) 'Arakawa A grid'
else
  write(*,*) 'Arakawa C grid'
endif

nx = nint(6.0_dp/dx + 1)
ny = nint(6.0_dp/dy + 1)

allocate(x(nx))
allocate(y(ny))
x = arange(-3.0_dp,3.0_dp,nx)
y = arange(-3.0_dp,3.0_dp,ny)

allocate(psi(nx,ny))
allocate(u(nx,ny))
allocate(v(nx,ny))

do j=1,ny
do i=1,nx
  psi(i,j) = psifunc(x(i),y(j))
enddo
enddo

if (agrid) then

! ...      u = - dPsi/dy
! ...      v =   dPsi/dx
  do j=1,ny
  do i=1,nx
    ! u(i,j) = -half*(psifunc(x(i),y(j)+dy) - psifunc(x(i),y(j)-dy))/dy
    ! v(i,j) =  half*(psifunc(x(i)+dx,y(j)) - psifunc(x(i)-dx,y(j)))/dx
      u(i,j) = -dpdy(x(i),y(j))*Uscale
      v(i,j) =  dpdx(x(i),y(j))*Uscale
  enddo
  enddo

  err = nf90_create(ofile,NF90_WRITE,fid)
  err = nf90_def_dim(fid,'x',nx,idi)
  err = nf90_def_dim(fid,'y',ny,idj)
  err = nf90_def_var(fid,'x',NF90_FLOAT,(/idi/),idx)
  err = nf90_def_var(fid,'y',NF90_FLOAT,(/idj/),idy)
  err = nf90_def_var(fid,'psi',NF90_FLOAT,(/idi,idj/),idp)
  err = nf90_def_var(fid,'u',NF90_FLOAT,(/idi,idj/),idu)
  err = nf90_def_var(fid,'v',NF90_FLOAT,(/idi,idj/),idv)
  err = nf90_enddef(fid)

  err = nf90_put_var(fid,idx,x)
  err = nf90_put_var(fid,idy,y)
  err = nf90_put_var(fid,idp,psi)
  err = nf90_put_var(fid,idu,u)
  err = nf90_put_var(fid,idv,v)

  err = nf90_close(fid)

else

  allocate (xu(nx))
  allocate (yu(ny))
  allocate (xv(nx))
  allocate (yv(ny))

  xu(:) = x(:) + half*dx
  yu(:) = y(:)
  xv(:) = x(:)
  yv(:) = y(:) + half*dy

  do j=1,ny
  do i=1,nx
    !u(i,j) = -half*(psifunc(xu(i),yu(j)+dy) - psifunc(xu(i),yu(j)-dy))/dy
    !v(i,j) =  half*(psifunc(xv(i)+dx,yv(j)) - psifunc(xv(i)-dx,yv(j)))/dx
    u(i,j) = -dpdy(xu(i),yu(j))*Uscale
    v(i,j) =  dpdx(xv(i),yv(j))*Uscale
  enddo
  enddo

  err = nf90_create(ofile,NF90_WRITE,fid)
  err = nf90_def_dim(fid,'x',nx,idi)
  err = nf90_def_dim(fid,'y',ny,idj)
  err = nf90_def_var(fid,'x_p',NF90_FLOAT,(/idi/),idxp)
  err = nf90_def_var(fid,'y_p',NF90_FLOAT,(/idj/),idyp)
  err = nf90_def_var(fid,'x_u',NF90_FLOAT,(/idi/),idxu)
  err = nf90_def_var(fid,'y_u',NF90_FLOAT,(/idj/),idyu)
  err = nf90_def_var(fid,'x_v',NF90_FLOAT,(/idi/),idxv)
  err = nf90_def_var(fid,'y_v',NF90_FLOAT,(/idj/),idyv)
  err = nf90_def_var(fid,'psi',NF90_FLOAT,(/idi,idj/),idp)
  err = nf90_def_var(fid,'u',NF90_FLOAT,(/idi,idj/),idu)
  err = nf90_def_var(fid,'v',NF90_FLOAT,(/idi,idj/),idv)
  err = nf90_enddef(fid)

  err = nf90_put_var(fid,idxp,x)
  err = nf90_put_var(fid,idyp,y)
  err = nf90_put_var(fid,idxu,xu)
  err = nf90_put_var(fid,idyu,yu)
  err = nf90_put_var(fid,idxv,xv)
  err = nf90_put_var(fid,idyv,yv)
  err = nf90_put_var(fid,idp,psi)
  err = nf90_put_var(fid,idu,u)
  err = nf90_put_var(fid,idv,v)

  err = nf90_close(fid)

endif

call stop_error(0,'Ok')

contains

  pure function psifunc(x,y) result(psi)
  real(dp), intent(in)     :: x,y
  real(dp)                 :: psi

  psi = half*(x*x+y*y+x*y)

  end function psifunc
  ! ...
  ! ===================================================================
  ! ...
  pure function dpdx (x,y) result(dpsi)
  real(dp), intent(in)     :: x,y
  real(dp)                 :: dpsi

  dpsi = x + half*y

  end function dpdx
  ! ...
  ! ===================================================================
  ! ...
  pure function dpdy (x,y) result(dpsi)
  real(dp), intent(in)     :: x,y
  real(dp)                 :: dpsi

  dpsi = y + half*x

  end function dpdy

end


c###gethp.for
      SUBROUTINE GETHP(FXX,HPX,HTX)
C--------------------------------
C
C     THIS ROUTINE PERFORMS GAUSSIAN INTEGRATION FOR THE VIRTUAL HEIGHTS
C     (SEE SUBROUTINE IONMUF FOR SETTING OF DATA)
C
      COMMON / DATR / WT(20), XT(20), NT, NPL, XNPL, TWDIV
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      FR = FXX * FXX
C.....FIRST FIND THE TRUE HEIGHT BY INTERPOLATION
      IF (FR - FNSQ (1,1))435, 435, 445
  435 HTX = HTR(1,1)
      HPX = HTX
      RETURN
  445 CONTINUE
      DO 490 IH = 1, 49
      IF (FNSQ (IH,1) - FNSQ (IH + 1,1))465, 455, 480
  455 IF (FR - FNSQ (IH,1))490, 460, 490
  460 HT = HTR (IH,1)
      GO TO 495
  465 IF (FNSQ (IH,1) - FR)470, 470, 475
  470 IF (FR - FNSQ (IH + 1,1))475, 490, 490
  475 HT = HTR (IH,1) + (FR - FNSQ (IH,1)) * (HTR(IH + 1,1) - HTR(IH,1))
     1 / (FNSQ (IH + 1,1) - FNSQ (IH,1))
      GO TO 495
  480 IF (FNSQ (IH,1) - FR)490, 485, 485
  485 IF (FR - FNSQ (IH + 1,1))490, 490, 475
  490 CONTINUE
      HT = HTR (50,1)
  495 CONTINUE
C.....END OF TRUE HEIGHT CALCULATION
      HP = 0
      HT = HT - HTR (1,1)
      HRMZ = HT * TWDIV * XNPL
      IF (NT .LT. 1) GO TO 665
C.....BEGINNING OF GAUSSIAN INTEGRATION
      DO 635 IG = 1, NT
      ZG = 1.0 - XT(IG)
C.....TRANSLATION TO (-1,1) FROM (0,HT) NEED NOT BE LINEAR
      ZI = HT * (1. - TWDIV * (ZG * * NPL)) + HTR (1,1)
      IB = - 1
      GO TO 535
  500 YSQ = YSQ / FR
      YSQ = AMIN1 (YSQ, 0.9999)
      YMUP = 1. / SQRT (1. - YSQ)
      YMUP = YMUP * (ZG * * (NPL - 1))
      ZG = 1. + XT (IG)
      ZI = HT * (1. - TWDIV * (ZG * * NPL)) + HTR (1,1)
      IB = 1
      GO TO 535
  505 YSQ = YSQ / FR
      YSQ = AMIN1 (YSQ, 0.9999)
      ZMUP = 1. / SQRT (1. - YSQ)
      ZMUP = ZMUP * (ZG * * (NPL - 1))
      GO TO 635
C.....BEGIN INTERPOLATION FOR PLASMA FREQUENCY SQUARED
  535 CONTINUE
      IF (ZI - HTR (1,1))545, 545, 555
  545 YSQ = FNSQ (1,1)
      GO TO 625
  555 CONTINUE
      DO 615 IH = 1, 49
      IF (HTR (IH,1) - HTR (IH + 1,1))585, 565, 605
  565 IF (ZI - HTR (IH,1))615, 575, 615
  575 YSQ = FNSQ (IH,1)
      GO TO 625
  585 IF (HTR (IH,1) - ZI)595, 595, 600
  595 IF (ZI - HTR (IH + 1,1))600, 615, 615
  600 YSQ = FNSQ (IH,1) + (ZI - HTR (IH,1)) * (FNSQ(IH+1,1)-FNSQ(IH,1))
     1 /(HTR (IH + 1,1) - HTR (IH,1))
      GO TO 625
  605 IF (HTR (IH,1) - ZI)615, 610, 610
  610 IF (ZI - HTR (IH + 1,1))615, 615, 600
  615 CONTINUE
      YSQ = FNSQ (50,1)
C.....END OF INTERPOLATION FOR PLASMA FREQUENCY SQUARED
  625 IF (IB)500, 500, 505
  635 HP = HP + WT (IG) * (YMUP + ZMUP)
C.....END OF GAUSSIAN INTEGRATION FOR VIRTUAL HEIGHTS
  665 CONTINUE
C.....HPX IS THE VIRTUAL HEIGHT
C.....HTX IS THE TRUE HEIGHT
      HPX = HTR(1,1) + HRMZ * HP
      HTX = HTR(1,1) + HT
      RETURN
      END
C--------------------------------


      subroutine beyond(ivtype,nccut,ccut,ccdf,ncut,cut,cdf,zmin,zmax,
     +           ltail,ltpar,middle,mpar,utail,utpar,zval,cdfval,ierr)
c-----------------------------------------------------------------------
c
c                     Go Beyond a Discrete CDF
c                     ************************
c
c This subroutine is a general purpose subroutine to interpolate within
c and extrapolate beyond discrete points on a conditional CDF.  If the
c Z value "zval" is specified then the corresponding CDF value "cdfval"
c will be computed, if the CDF value "cdfval" is specified the
c corresponding Z value "zval" will be computed.
c
c
c
c INPUT/OUTPUT VARIABLES:
c
c   ivtype           variable type (1=continuous, 0=categorical)
c   nccut            number of cutoffs defining the conditional CDF
c   ccut()           real array of the nccut cutoffs
c   ccdf()           real array of the conditional cdf values
c   ncut             number of cutoffs defining the global CDF
c   cut()            real array of the ncut cutoffs
c   cdf()            real array of the global cdf values
c
c   zmin,zmax        minimum and maximum allowable data values
c   ltail            option to handle values in lower tail
c   ltpar            parameter required for option ltail
c   middle           option to handle values in the middle
c   mpar             parameter required for option middle
c   utail            option to handle values in upper tail
c   utpar            parameter required for option utail
c
c   zval             interesting cutoff (if -1 then it is calculated)
c   cdfval           interesting CDF (if -1 then it is calculated)
c
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20,UNEST=-1.0)
      dimension ccut(nccut),ccdf(nccut),cut(1),cdf(1)
      real      utpar,mpar,ltpar,lambda
      integer   ltail,utail,middle,cclow,cchigh
c
c Check for both "zval" and "cdfval" defined or undefined:
c
      ierr  = 1
      if(zval.gt.UNEST.and.cdfval.gt.UNEST) return
      if(zval.le.UNEST.and.cdfval.le.UNEST) return
c
c Handle the case of a categorical variable:
c
      if(ivtype.eq.0) then
            cum = 0
            do i=1,nccut
                  cum = cum + ccdf(i)
                  if(cdfval.le.cum) then
                         zval = ccut(i)
                         return
                  endif
            end do
            return
      end if
c
c Figure out what part of distribution: ipart = 0 - lower tail
c                                       ipart = 1 - middle
c                                       ipart = 2 - upper tail
      ierr  = 0
      ipart = 1
      if(zval.gt.UNEST) then
            if(zval.le.ccut(1))       ipart = 0
            if(zval.ge.ccut(nccut))   ipart = 2
      else
            if(cdfval.le.ccdf(1))     ipart = 0
            if(cdfval.ge.ccdf(nccut)) ipart = 2
      endif
c
c ARE WE IN THE LOWER TAIL?
c
      if(ipart.eq.0) then
            if(ltail.eq.1) then
c
c Straight Linear Interpolation:
c
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(zmin,ccut(1),0.0,ccdf(1),
     +                                  zval,powr)
                  else
                        zval = powint(0.0,ccdf(1),zmin,ccut(1),
     +                                cdfval,powr)
                  endif
            else if(ltail.eq.2) then
c
c Power Model interpolation to lower limit "zmin"?
c
                  if(zval.gt.UNEST) then
                        cdfval = powint(zmin,ccut(1),0.0,ccdf(1),
     +                                  zval,ltpar)
                  else
                        powr = 1.0 / ltpar
                        zval = powint(0.0,ccdf(1),zmin,ccut(1),
     +                                cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(ltail.eq.3) then
                  if(zval.gt.UNEST) then
c
c Computing the cdf value. Locate the point and the class bound:
c
                        call locate(cut,ncut,1,ncut,zval,idat)
                        call locate(cut,ncut,1,ncut,ccut(1),iupp)
c
c Straight linear interpolation if no data; otherwise, linear:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut) then
                               cdfval = powint(zmin,cut(1),0.0,cdf(1),
     +                                         zval,1.)
                         else
                               temp   = powint(cut(idat),cut(idat+1),
     +                                    cdf(idat),cdf(idat+1),zval,1.)
                               cdfval = temp*ccdf(1)/cdf(iupp)
                         endif
                   else
c
c Computing Z value: Are there any data out in the tail?
c
                         call locate(cut,ncut,1,ncut,ccut(1),iupp)
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(iupp.le.0.or.iupp.ge.ncut) then
                              zval = powint(0.0,cdf(1),zmin,cut(1),
     +                                      cdfval,1.)
                        else
                              temp = cdfval*cdf(iupp)/ccdf(1)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(idat.le.0.or.idat.ge.ncut) then
                                    zval = powint(0.0,cdf(1),zmin,
     +                                            cut(1),cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              end if
                        endif
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
c
c FINISHED THE LOWER TAIL,  ARE WE IN THE MIDDLE?
c
      if(ipart.eq.1) then
c
c Establish the lower and upper limits:
c
            if(zval.gt.UNEST) then
                  call locate(ccut,nccut,1,nccut,zval,cclow)
            else
                  call locate(ccdf,nccut,1,nccut,cdfval,cclow)
            endif
            cchigh = cclow + 1
            if(middle.eq.1) then
c
c Straight Linear Interpolation:
c
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh),
     +                           ccdf(cclow),ccdf(cchigh),zval,powr)
                  else
                        zval = powint(ccdf(cclow),ccdf(cchigh),
     +                         ccut(cclow),ccut(cchigh),cdfval,powr)
                  endif
c
c Power interpolation between class bounds?
c
            else if(middle.eq.2) then
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(cclow),ccut(cchigh),
     +                           ccdf(cclow),ccdf(cchigh),zval,mpar)
                  else
                        powr = 1.0 / mpar
                        zval = powint(ccdf(cclow),ccdf(cchigh),
     +                         ccut(cclow),ccut(cchigh),cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(middle.eq.3) then
                  call locate(cut,ncut,1,ncut,ccut(cclow),ilow)
                  call locate(cut,ncut,1,ncut,ccut(cchigh),iupp)
                  if(cut(ilow).lt.ccut(cclow))  ilow = ilow + 1
                  if(cut(iupp).gt.ccut(cchigh)) iupp = iupp - 1
                  if(zval.gt.UNEST) then
                        call locate(cut,ncut,1,ncut,zval,idat)
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     ilow.le.0.or.ilow.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut.or.
     +                     iupp.le.ilow) then
                              cdfval=powint(ccut(cclow),ccut(cchigh),
     +                                ccdf(cclow),ccdf(cchigh),zval,1.)
                        else
                              temp = powint(cut(idat),cut(idat+1),
     +                                cdf(idat),cdf(idat+1),zval,1.)
                              cdfval=powint(cdf(ilow),cdf(iupp),
     +                                ccdf(cclow),ccdf(cchigh),temp,1.)
                        endif
                  else
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(ilow.le.0.or.ilow.ge.ncut.or.
     +                     iupp.le.0.or.iupp.ge.ncut.or.
     +                     iupp.le.ilow) then
                              zval=powint(ccdf(cclow),ccdf(cchigh),
     +                              ccut(cclow),ccut(cchigh),cdfval,1.)
                        else
                              temp=powint(ccdf(cclow),ccdf(cchigh),
     +                              cdf(ilow),cdf(iupp),cdfval,1.)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(cut(idat).lt.ccut(cclow)) idat=idat+1
                              if(idat.le.0.or.idat.ge.ncut.or.
     +                           cut(idat+1).gt.ccut(cchigh)) then
                                    zval = powint(ccdf(cclow),
     +                                     ccdf(cchigh),ccut(cclow),
     +                                     ccut(cchigh),cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              end if
                              zval = powint(cdf(idat),cdf(idat+1),
     +                                cut(idat),cut(idat+1),temp,1.)
                        endif
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
c
c FINISHED THE MIDDLE,  ARE WE IN THE UPPER TAIL?
c
      if(ipart.eq.2) then
            if(utail.eq.1) then
                  powr = 1.0
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut),
     +                                  1.0,zval,powr)
                  else
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut),
     +                                  zmax,cdfval,powr)
                  endif

            else if(utail.eq.2) then
c
c Power interpolation to upper limit "utpar"?
c
                  if(zval.gt.UNEST) then
                        cdfval = powint(ccut(nccut),zmax,ccdf(nccut),
     +                                  1.0,zval,utpar)
                  else
                        powr = 1.0 / utpar
                        zval   = powint(ccdf(nccut),1.0,ccut(nccut),
     +                                  zmax,cdfval,powr)
                  endif
c
c Linear interpolation between the rescaled global cdf?
c
            else if(utail.eq.3) then
                  if(zval.gt.UNEST) then
c
c Approximately Locate the point and the class bound:
c
                        call locate(cut,ncut,1,ncut,zval,idat)
                        call locate(cut,ncut,1,ncut,ccut(nccut),ilow)
                        if(cut(idat).lt.zval)        idat = idat + 1
                        if(cut(ilow).lt.ccut(nccut)) ilow = ilow + 1
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(idat.le.0.or.idat.ge.ncut.or.
     +                     ilow.le.0.or.ilow.ge.ncut) then
                              cdfval = powint(ccut(nccut),zmax,
     +                                  ccdf(nccut),1.0,zval,1.)
                        else
                              temp   = powint(cut(idat),cut(idat+1),
     +                                  cdf(idat),cdf(idat+1),zval,1.)
                              cdfval = powint(cdf(ilow),1.0,
     +                                  ccdf(nccut),1.0,temp,1.)
                        endif
                  else
c
c Computing Z value: Are there any data out in the tail?
c
                        call locate(cut,ncut,1,ncut,ccut(nccut),ilow)
                        if(cut(ilow).lt.ccut(nccut)) ilow = ilow + 1
c
c Straight linear interpolation if no data; otherwise, local linear
c interpolation:
c
                        if(ilow.le.0.or.ilow.ge.ncut) then
                              zval   = powint(ccdf(nccut),1.0,
     +                                  ccut(nccut),zmax,cdfval,1.)
                        else
                              temp = powint(ccdf(nccut),1.0,
     +                                cdf(ilow),1.0,cdfval,1.)
                              call locate(cdf,ncut,1,ncut,temp,idat)
                              if(cut(idat).lt.ccut(nccut)) idat=idat+1
                              if(idat.ge.ncut) then
                                    zval   = powint(ccdf(nccut),1.0,
     +                                       ccut(nccut),zmax,cdfval,1.)
                              else
                                    zval = powint(cdf(idat),cdf(idat+1),
     +                                   cut(idat),cut(idat+1),temp,1.)
                              endif
                        endif
                  endif
c
c Fit a Hyperbolic Distribution?
c
            else if(utail.eq.4) then
c
c Figure out "lambda" and required info:
c
                  lambda = (ccut(nccut)**utpar)*(1.0-ccdf(nccut))
                  if(zval.gt.UNEST) then
                        cdfval = 1.0 - (lambda/(zval**utpar))
                  else
                        zval = (lambda/(1.0-cdfval))**(1.0/utpar)
                  endif
            else
c
c Error situation - unacceptable option:
c
                  ierr = 2
                  return
            endif
      endif
      if(zval.lt.zmin) zval = zmin
      if(zval.gt.zmax) zval = zmax
c
c All finished - return:
c
      return
      end


*
      SUBROUTINE SOR( N, B, X, WORK, LDW, ITER, RESID, MATVEC,
     $                BACKSOLVE, INFO )
*
*  -- Iterative template routine --
*     Univ. of Tennessee and Oak Ridge National Laboratory
*     October 1, 1993
*     Details of this algorithm are described in "Templates for the
*     Solution of Linear Systems: Building Blocks for Iterative
*     Methods", Barrett, Berry, Chan, Demmel, Donato, Dongarra,
*     Eijkhout, Pozo, Romine, and van der Vorst, SIAM Publications,
*     1993. (ftp netlib2.cs.utk.edu; cd linalg; get templates.ps).
*
*     .. Scalar Arguments ..
      INTEGER            N, LDW, ITER, INFO
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( * ), X( * ), WORK( * )
*     ..
*     .. Function Arguments ..
      EXTERNAL           MATVEC, BACKSOLVE
*
*  Purpose
*  =======
*
*  SOR solves the linear system Ax = b using the Successive
*  Over-Relaxation iterative method.
*  The matrix splitting is formed by copying the strict upper
*  triangular portion of A onto matrix N, stored in WORK. Matrix M
*  is the lower triangular portion of A.
*  On exit, matrix A and right hand side b are reset to their
*  original form.
*
*  Relative error measured: norm( X - X_1 ) / norm( X ).
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          On entry, the dimension of the matrix.
*          Unchanged on exit.
*
*  B       (input) DOUBLE PRECISION array, dimension N
*          On entry, right hand side vector B.
*          Unchanged on exit.
*
*  X       (input/output) DOUBLE PRECISION array, dimension N.
*          On input, the initial guess. This is commonly set to
*          the zero vector.
*          On exit, if INFO = 0, the iterated approximate solution.
*
*  WORK    (input/workspace) DOUBLE PRECISION array, dimension (N*(N+3)).
*          The relaxation parameter, OMEGA, should be input in WORK(1).
*          The amount of workspace can be significantly reduced (to 2*N)
*          by customizing the matrix-vector product and backsolve.
*
*  LDW     (input) INTEGER
*          The leading dimension of the array WORK. LDW >= max(1,N).
*
*  ITER    (input/output) INTEGER
*          On input, the maximum iterations to be performed.
*          On output, actual number of iterations performed.
*
*  RESID   (input/output) DOUBLE PRECISION
*          On input, the allowable convergence measure for
*          norm( x - x_1 ) / norm( x ).
*          On output, the final value of this measure.
*
*  MATVEC  (external subroutine)
*          The user must provide a subroutine to perform the
*          matrix-vector product
*
*               y := alpha*A*x + beta*y,
*
*          where alpha and beta are scalars, x and y are vectors,
*          and A is a matrix. Vector x must remain unchanged.
*          The solution is over-written on vector y.
*
*          The call is:
*
*             CALL MATVEC( ALPHA, X, BETA, Y )
*
*          The matrix is passed into the routine in a common block.
*
*  BACKSOLVE (external subroutine)
*          The user must provide a subroutine to perform the
*          linear system solve
*
*               x := M*x,
*
*          where x is a vector and M is a lower triangular matrix.
*          The solution is over-written on vector x.
*
*          The call is:
*
*             CALL BACKSOLVE( N, M, LDM, X )
*
*          The matrix is passed into the routine in a common block.
*
*  INFO    (output) INTEGER
*
*          =  0: Successful exit. Iterated approximate solution returned.
*
*          >  0: Convergence to tolerance not achieved. This will be
*                set to the number of iterations performed.
*
*          <  0: Illegal input parameter, or breakdown occurred
*                during iteration.
*
*                Illegal parameter:
*
*                   -1: matrix dimension N < 0
*                   -2: LDW < N
*                   -3: Maximum number of iterations ITER <= 0.
*                   -4: Relaxation parameter OMEGA not in interval (0,2).
*
*     ==========================================================
*
*
*This variable used to communicate requests between SOR() and SORREVCOM()
*SOR -> SORREVCOM: 1 = init,
*                2 = use saved state to resume flow.
*SORREVCOM -> SOR: -1 = done, return to main,
*                 1 = matvec using SCLR1/2, NDX1/2
*                 2 = solve using NDX1/2
      INTEGER          IJOB
*
*     Arg/Result indices into WORK[].
      INTEGER NDX1, NDX2
*     Scalars passed from SORREVCOM to SOR.
      DOUBLE PRECISION SCLR1, SCLR2
*     Vars reqd for STOPTEST2
      DOUBLE PRECISION TOL, XNRM2
*     ..
*     .. External subroutines ..
      EXTERNAL         SORREVCOM, STOPTEST2
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
*     Test the input parameters.
*
      IF ( N.LT.0 ) THEN
         INFO = -1
      ELSE IF ( LDW.LT.MAX( 1, N ) ) THEN
         INFO = -2
      ELSE IF ( ITER.LE.0 ) THEN
         INFO = -3
      ELSE IF ( ( WORK( 1 ).LE.0 ).OR.( WORK( 1 ).GE.2 ) ) THEN
         INFO = -4
      ENDIF
      IF ( INFO.NE.0 ) RETURN
*
*     Stop test may need some indexing info from REVCOM
*     use the init call to send the request across. REVCOM
*     will note these requests, and everytime it asks for
*     stop test to be done, it will provide the indexing info.
*
*     1 == X1; 2 == TEMP; 3 == MM; -1 == ignore; any other == error
      NDX1 = 1
      NDX2 = -1
      TOL = RESID
*
*     First time call always init.
*
      IJOB = 1

 1    CONTINUE

          CALL SORREVCOM(N, B, X, WORK, LDW, ITER, RESID, INFO,
     $                   NDX1, NDX2, SCLR1, SCLR2, IJOB)

*         On a return from REVCOM() we use the table
*         to decode IJOB.
          IF (IJOB .eq. -1) THEN
*           revcom wants to terminate, so do it.
            GOTO 2
          ELSEIF (IJOB .eq. 1) THEN
*           call matvec with X.
            CALL MATVEC(SCLR1, X, SCLR2, WORK(NDX2))
          ELSEIF (IJOB .eq. 2) THEN
*           call backsolve with X
            CALL BACKSOLVE(N, WORK(NDX1), LDW, X)
         ELSEIF (IJOB .EQ. 3) THEN
*           do stopping test 2
*           XNRM2 shld be recomputed everytime.
            INFO = -1
            CALL STOPTEST2(N, WORK(NDX1), X, XNRM2, RESID, TOL, INFO)
         ENDIF
*
*     done what revcom asked, set IJOB & go back to it.
      IJOB = 2
      GOTO 1
*
*     come here to terminate
 2    CONTINUE
*
*
      RETURN
*
*     End of SOR
*
      END


      subroutine msolvr(aamatr,delvec,gmmatr,ier,ipivot,kdim,kmax,
     $ noutpt,nttyo,qpr,rhsvec)
c
c     This subroutine solves the matrix equation:
c
c       (aamatr)(delvec) = (rhsvec)
c
c     The method employed is L-U decomposition. The original aamatr
c     matrix is preserved. The workspace vector gmmatr holds the
c     L-U decomposition.
c
c     This subroutine uses
c     the following subroutines, which are adaptations of 1979 Linpack
c     subroutines of the same names:
c
c       EQLIBU/dgefa.f
c       EQLIBU/dgesl.f
c
c     The calling sequences have been preserved to facilitate
c     substituting equivalents optimized for specific platforms,
c     for anyone desiring to do so.
c
c     This subroutine is called by:
c
c       EQLIBU/polfit.f
c       EQLIBU/minvrt.f
c       EQLIB/nrstep.f
c       EQ3NR/arrsim.f
c       EQ6/jgibbs.f
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       aamatr = the matrix
c       kdim   = the actual dimention of the matrix
c       kmax   = the maximum dimension of the matrix
c       noutpt = the unit number of the output file
c       nttyo  = the unit number of the screen file
c       rhsvec = the right hand side vector
c       qpr    = logical switch to print messages from this subroutine
c
c     Workspace:
c
c       gmmatr = work space for a copy of the matrix; holds the
c                  L-U decomposition
c       ipivot = the pivot vector
c
c     Output:
c
c       delvec = the solution vector
c       ier    = error flag:
c                  =  1  Encountered a zero matrix
c                  =  2  Encountered a non-zero, computationally
c                          singular matrix
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax
c
      integer noutpt,nttyo
c
      integer ipivot(kmax)
      integer ier,kdim
c
      logical qpr
c
      real*8 aamatr(kmax,kmax),gmmatr(kmax,kmax),rhsvec(kmax),
     $ delvec(kmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer info,j,k
c
c-----------------------------------------------------------------------
c
c     Initialize error flag.
c
      ier = 0
c
c     Copy aamatr to gmmatr.
c
      do k = 1,kdim
        do j = 1,kdim
          gmmatr(j,k) = aamatr(j,k)
        enddo
      enddo
c
c     OR
c
c     do k = 1,kdim
c       call copyaa(aamatr(1,k),gmmatr(1,k),kdim)
c     enddo
c
c     OR
c
c     integer nmax
c     nmax = kmax*kdim
c     call copyaa(aamatr,gmmatr,nmax)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Avoid trying to decompose a zero matrix.
c
      do k = 1,kdim
        do j = 1,kdim
          if (gmmatr(j,k) .ne. 0.) go to 100
        enddo
      enddo
      ier = 1
      if (qpr) then
        write (noutpt,1000)
        write (nttyo,1000)
 1000   format(/' * Note - (EQLIBU/msolvr) Have a zero matrix to',
     $  ' factor.')
      endif
      go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Factor the matrix (make the L-U decomposition).
c
  100 call dgefa(gmmatr,kmax,kdim,ipivot,info)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Test info.
c
      if (info .ne. 0) then
        ier = 2
        if (qpr) then
          write (noutpt,1010)
          write (nttyo,1010)
 1010     format(/' * Note - (EQLIBU/msolvr) Have a computationally',
     $    ' singular matrix.')
        endif
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c      Copy rhsvec to delvec.
c
      do j = 1,kdim
        delvec(j) = rhsvec(j)
      enddo
c
c     OR
c
c     call copyaa(rhsvec,delvec,kdim)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Solve for the unknown vector (delvec). Note that delvec initially
c     contains a copy of the right-hand-side vector.
c
      call dgesl(gmmatr,kmax,kdim,ipivot,delvec)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


      implicit real *8 (a-h,o-z)
      real *8, allocatable :: sources(:,:),targ(:,:)
      real *8, allocatable :: dipvec(:,:)
      complex *16, allocatable :: charges(:),dipstr(:)
      complex *16, allocatable :: pot(:),grad(:,:),hess(:,:)
      complex *16, allocatable :: pottarg(:),gradtarg(:,:),hesstarg(:,:)
      character(len=72) str1

      integer ipass(27)

      complex *16 ima,zk
      data ima/(0.0d0,1.0d0)/

      call prini(6,13)

      done = 1
      pi = atan(done)*4

      nsrc = 40000
      ntarg = nsrc+10

      allocate(sources(2,nsrc),charges(nsrc),dipstr(nsrc))
      allocate(targ(2,ntarg),dipvec(2,nsrc))
      allocate(pot(nsrc),grad(2,nsrc),hess(3,nsrc))
      allocate(pottarg(ntarg),gradtarg(2,ntarg),hesstarg(3,ntarg))

      do i=1,nsrc
        sources(1,i) = hkrand(0)
        sources(2,i) = hkrand(0)

        charges(i) = hkrand(0) + ima*hkrand(0)
        dipstr(i) = hkrand(0) + ima*hkrand(0)

        dipvec(1,i) = hkrand(0)
        dipvec(2,i) = hkrand(0)
      enddo

      do i=1,ntarg
         targ(1,i) = hkrand(0)
         targ(2,i) = hkrand(0)
      enddo

c
cc      test low frequency mode
c
      zk = 0.5d0 + 0.1d0*ima
      zk = 100
cc      zk = 500.0d0
      eps = 0.51d-8

      write(*,*) "=========================================="
      write(*,*) "Testing suite for hfmm2d"
      write(*,'(a,e11.4)') "Requested precision = ",eps
      write(6,*)
      write(6,*)

      open(unit=33,file='print_testres.txt',access='append')

      ntests = 27
      do i=1,ntests
        ipass(i) = 0
      enddo

      ntest = 20
      nts = min(ntest,nsrc)
      ntt = min(ntest,ntarg)
      thresh = 2.0d0**(-51)

c
c
cc      now test source to source, charge
c       with potentials
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_s_c_p(eps,zk,nsrc,sources,charges,
     1        pot,ier)

      ifcharge = 1
      ifdipole = 0
      ifpgh = 1
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(1) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

      stop

c
c
cc      now test source to source, charge
c       with gradients
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_s_c_g(eps,zk,nsrc,sources,charges,
     1        pot,grad,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 2
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(2) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source, charge
c       with hessians
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_s_c_h(eps,zk,nsrc,sources,charges,
     1        pot,grad,hess,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 3
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(3) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
c
c
cc      now test source to source, dipole
c       with potentials
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_s_d_p(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,ier)

c
cc       test against exact potential
c
      ifcharge = 0
      ifdipole = 1
      ifpgh = 1
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(4) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source, dipole
c       with gradients
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_s_d_g(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,grad,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 2
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(5) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source, dipole
c       with hessians
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_s_d_h(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,grad,hess,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 3
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(6) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
c
c
cc      now test source to source, charge + dipole
c       with potentials
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_s_cd_p(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 1
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(7) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source, charge + dipole
c       with gradients
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_s_cd_g(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,grad,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 2
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(8) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source, charge + dipole
c       with hessians
c
      write(6,*) 'testing source to sources'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_s_cd_h(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,grad,hess,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 3
      ifpghtarg = 0
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(9) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
cc      now test source to target, charge
c       with potentials
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_t_c_p(eps,zk,nsrc,sources,charges,
     1        ntarg,targ,pottarg,ier)

      ifcharge = 1
      ifdipole = 0
      ifpgh = 0
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(10) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, charge
c       with gradients
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_t_c_g(eps,zk,nsrc,sources,charges,
     1        ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 0
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(11) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, charge
c       with hessians
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_t_c_h(eps,zk,nsrc,sources,charges,
     1        ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 0
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(12) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
c
c
cc      now test source to target, dipole
c       with potentials
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_t_d_p(eps,zk,nsrc,sources,dipstr,
     1        dipvec,ntarg,targ,pottarg,ier)

c
cc       test against exact potential
c
      ifcharge = 0
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(13) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, dipole
c       with gradients
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_t_d_g(eps,zk,nsrc,sources,dipstr,
     1        dipvec,ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(14) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, dipole
c       with hessians
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_t_d_h(eps,zk,nsrc,sources,dipstr,
     1        dipvec,ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(15) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

cccc      nsrc = n
cccc      ntarg = nsrc

c
c
c
c
cc      now test source to target, charge + dipole
c       with potentials
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_t_cd_p(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,ntarg,targ,pottarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(16) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, charge + dipole
c       with gradients
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_t_cd_g(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(17) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to target, charge + dipole
c       with hessians
c
      write(6,*) 'testing source to targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_t_cd_h(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 0
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(18) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, charge
c       with potentials
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_st_c_p(eps,zk,nsrc,sources,charges,
     1        pot,ntarg,targ,pottarg,ier)

      ifcharge = 1
      ifdipole = 0
      ifpgh = 1
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(19) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, charge
c       with gradients
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_st_c_g(eps,zk,nsrc,sources,charges,
     1        pot,grad,ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 2
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(20) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, charge
c       with hessians
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_st_c_h(eps,zk,nsrc,sources,charges,
     1        pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 0
      ifpgh = 3
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(21) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
c
c
cc      now test source to source  + target, dipole
c       with potentials
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_st_d_p(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,ntarg,targ,pottarg,ier)

c
cc       test against exact potential
c
      ifcharge = 0
      ifdipole = 1
      ifpgh = 1
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(22) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, dipole
c       with gradients
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_st_d_g(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,grad,ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 2
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(23) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, dipole
c       with hessians
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_st_d_h(eps,zk,nsrc,sources,dipstr,
     1        dipvec,pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 0
      ifdipole = 1
      ifpgh = 3
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(24) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
c
c
cc      now test source to source  + target, charge + dipole
c       with potentials
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials'
      write(6,*)
      write(6,*)

      call hfmm2d_st_cd_p(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,ntarg,targ,pottarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 1
      ifpghtarg = 1
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(25) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, charge + dipole
c       with gradients
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients'
      write(6,*)
      write(6,*)

      call hfmm2d_st_cd_g(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,grad,ntarg,targ,pottarg,gradtarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 2
      ifpghtarg = 2
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(26) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

c
c
cc      now test source to source  + target, charge + dipole
c       with hessians
c
      write(6,*) 'testing source to source and targets'
      write(6,*) 'interaction: charges + dipoles'
      write(6,*) 'output: potentials + gradients + hessians'
      write(6,*)
      write(6,*)

      call hfmm2d_st_cd_h(eps,zk,nsrc,sources,charges,dipstr,
     1        dipvec,pot,grad,hess,ntarg,targ,pottarg,gradtarg,
     2        hesstarg,ier)
c
cc       test against exact potential
c

      ifcharge = 1
      ifdipole = 1
      ifpgh = 3
      ifpghtarg = 3
c
c   compute error
c

      call comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1  dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2  pottarg,gradtarg,hesstarg,ntest,erra)

      call prin2('l2 rel error=*',erra,1)
      write(6,*)
      write(6,*)
      write(6,*) '====================='

      if(erra.lt.eps) ipass(27) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(erra.ge.eps) write(33,*) str1(1:len1)

      isum = 0
      do i=1,ntests
        isum = isum+ipass(i)
      enddo

      write(*,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in hfmm2d testing suite'
      write(33,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in hfmm2d testing suite'
      close(33)

      stop
      end
c
c
c
c
c
      subroutine comperr(zk,nsrc,sources,ifcharge,charges,ifdipole,
     1   dipstr,dipvec,ifpgh,pot,grad,hess,ntarg,targ,ifpghtarg,
     2   pottarg,gradtarg,hesstarg,ntest,erra)
      implicit real *8 (a-h,o-z)
      complex *16 zk
      real *8 sources(2,*),targ(2,*),dipvec(2,*)
      complex *16 charges(*),dipstr(*)
      integer ifcharge,ifdipole,ifpgh,ifpghtarg
      complex *16 pot(*),grad(2,*),hess(3,*),pottarg(*)
      complex *16 gradtarg(2,*),hesstarg(3,*)
      real *8 erra

      complex *16, allocatable :: potex(:),gradex(:,:),hessex(:,:)
      complex *16, allocatable :: pottargex(:),gradtargex(:,:),
     1                             hesstargex(:,:)

      allocate(potex(ntest),gradex(2,ntest),hessex(3,ntest))
      allocate(pottargex(ntest),gradtargex(2,ntest),hesstargex(3,ntest))

      nts = 0
      ntt = 0
      if(ifpgh.ge.1) nts = min(ntest,nsrc)
      if(ifpghtarg.ge.1) ntt = min(ntest,ntarg)

      do i=1,nts
        if(ifpgh.ge.1) potex(i) = 0
        if(ifpgh.ge.2) then
          gradex(1,i) = 0
          gradex(2,i) = 0
        endif
        if(ifpgh.ge.3) then
          hessex(1,i) = 0
          hessex(2,i) = 0
          hessex(3,i) = 0
        endif
      enddo

      do i=1,ntt
        if(ifpghtarg.ge.1) pottargex(i) = 0
        if(ifpghtarg.ge.2) then
          gradtargex(1,i) = 0
          gradtargex(2,i) = 0
        endif
        if(ifpghtarg.ge.3) then
          hesstargex(1,i) = 0
          hesstargex(2,i) = 0
          hesstargex(3,i) = 0
        endif
      enddo

      thresh = 2.0d0**(-51)

      call hfmm2dpart_direct(1,1,nsrc,1,nts,zk,sources,ifcharge,
     1       charges,ifdipole,dipstr,dipvec,sources,ifpgh,potex,
     2       gradex,hessex,thresh)

      call hfmm2dpart_direct(1,1,nsrc,1,ntt,zk,sources,ifcharge,
     1       charges,ifdipole,dipstr,dipvec,targ,ifpghtarg,pottargex,
     2       gradtargex,hesstargex,thresh)
      erra = 0
      ra = 0

      do i=1,nts
        if(ifpgh.ge.1) then
          erra = erra + abs(pot(i) - potex(i))**2
          ra = ra + abs(potex(i))**2
        endif
        if(ifpgh.ge.2) then
          erra = erra + abs(grad(1,i)-gradex(1,i))**2
          erra = erra + abs(grad(2,i)-gradex(2,i))**2
          ra = ra + abs(gradex(1,i))**2
          ra = ra + abs(gradex(2,i))**2
        endif
        if(ifpgh.ge.3) then
          erra = erra + abs(hess(1,i)-hessex(1,i))**2
          erra = erra + abs(hess(2,i)-hessex(2,i))**2
          erra = erra + abs(hess(3,i)-hessex(3,i))**2
          ra = ra + abs(hessex(1,i))**2
          ra = ra + abs(hessex(2,i))**2
          ra = ra + abs(hessex(3,i))**2
        endif
      enddo

      do i=1,ntt
        if(ifpghtarg.ge.1) then
          erra = erra + abs(pottarg(i) - pottargex(i))**2
          ra = ra + abs(pottargex(i))**2
        endif
        if(ifpghtarg.ge.2) then
          erra = erra + abs(gradtarg(1,i)-gradtargex(1,i))**2
          erra = erra + abs(gradtarg(2,i)-gradtargex(2,i))**2
          ra = ra + abs(gradtargex(1,i))**2
          ra = ra + abs(gradtargex(2,i))**2
        endif
        if(ifpghtarg.ge.3) then
          erra = erra + abs(hesstarg(1,i)-hesstargex(1,i))**2
          erra = erra + abs(hesstarg(2,i)-hesstargex(2,i))**2
          erra = erra + abs(hesstarg(3,i)-hesstargex(3,i))**2
          ra = ra + abs(hesstargex(1,i))**2
          ra = ra + abs(hesstargex(2,i))**2
          ra = ra + abs(hesstargex(3,i))**2
        endif
      enddo

      erra = sqrt(erra/ra)

      return
      end


! ==============================================================================
!  Point-wise version of a simple scalar advection problem
! ==============================================================================

subroutine rp1_ptwise(num_eqn, num_aux, num_waves, q_l, q_r, aux_l, aux_r,    &
                      wave, s, amdq, apdq)

    implicit none

    ! Input Arguments
    integer, intent(in) :: num_eqn, num_aux, num_waves
    real(kind=8), intent(in out) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in out) :: aux_l(num_aux), aux_r(num_aux)

    ! Output arguments
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Common block
    real(kind=8) :: u

    common /cparam/ u

    s = u
    wave(1, 1) = q_r(1) - q_l(1)

    amdq = min(u, 0.0) * wave(1, 1)
    apdq = max(u, 0.0) * wave(1, 1)

end subroutine rp1_ptwise


      SUBROUTINE DTRIDGL(L,AF,BF,CF,DF,XK)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

      implicit none

!     DOUBLE PRESCISION VERSION OF TRIDGL

      integer, parameter :: NMAX = 201
      integer :: L, I

      real*8  :: AF(L),BF(L),CF(L),DF(L),XK(L)
      real*8  :: AS(NMAX),DS(NMAX), X, XKB

!*    THIS SUBROUTINE SOLVES A SYSTEM OF TRIDIAGIONAL MATRIX
!*    EQUATIONS. THE FORM OF THE EQUATIONS ARE:
!*    A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = D(I)
!*    WHERE I=1,L  LESS THAN 103.
!* ..............REVIEWED -CP........

!======================================================================C

      AS(L) = AF(L)/BF(L)
      DS(L) = DF(L)/BF(L)

      DO I=2,L
        X         = 1./(BF(L+1-I) - CF(L+1-I)*AS(L+2-I))
        AS(L+1-I) = AF(L+1-I)*X
        DS(L+1-I) = (DF(L+1-I)-CF(L+1-I)*DS(L+2-I))*X
      END DO

      XK(1)=DS(1)
      DO I=2,L
        XKB   = XK(I-1)
        XK(I) = DS(I)-AS(I)*XKB
      END DO

      RETURN
      end subroutine dtridgl


C * * * * * * * * * * * * * * * * * * * * * * * * *
C --- DRIVER FOR DOPRI5 ON ARENSTORF ORBIT
C * * * * * * * * * * * * * * * * * * * * * * * * *
        IMPLICIT REAL*8 (A-H,O-Z)
        PARAMETER (NDGL=4,NRDENS=2)
        PARAMETER (LWORK=8*NDGL+5*NRDENS+21,LIWORK=NRDENS+21)
        DIMENSION Y(NDGL),WORK(LWORK),IWORK(LIWORK),RPAR(2)
        EXTERNAL FAREN,SOLOUT
C --- DIMENSION OF THE SYSTEM
        N=NDGL
C --- OUTPUT ROUTINE (AND DENSE OUTPUT) IS USED DURING INTEGRATION
        IOUT=2
C --- INITIAL VALUES AND ENDPOINT OF INTEGRATION
        RPAR(1)=0.012277471D0
        RPAR(2)=1.D0-RPAR(1)
        X=0.0D0
        Y(1)=0.994D0
        Y(2)=0.0D0
        Y(3)=0.0D0
        Y(4)=-2.00158510637908252240537862224D0
        XEND=17.0652165601579625588917206249D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=1.0D-7
        ATOL=RTOL
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.D0
C --- DENSE OUTPUT IS USED FOR THE TWO POSITION COORDINATES 1 AND 2
        IWORK(5)=NRDENS
        IWORK(21)=1
        IWORK(22)=2
C --- CALL OF THE SUBROUTINE DOPRI5
        CALL DOPRI5(N,FAREN,X,Y,XEND,
     &              RTOL,ATOL,ITOL,
     &              SOLOUT,IOUT,
     &              WORK,LWORK,IWORK,LIWORK,RPAR,IPAR,IDID)
C --- PRINT FINAL SOLUTION
        WRITE (6,99) Y(1),Y(2)
 99     FORMAT(1X,'X = XEND     Y =',2E18.10)
C --- PRINT STATISTICS
        WRITE (6,91) RTOL,(IWORK(J),J=17,20)
 91     FORMAT('     tol=',D8.2,'   fcn=',I5,' step=',I4,
     &             ' accpt=',I4,' rejct=',I3)
        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,CON,ICOMP,ND,RPAR,IPAR,IRTRN)
C --- PRINTS SOLUTION AT EQUIDISTANT OUTPUT-POINTS BY USING "CONTD5"
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),CON(5*ND),ICOMP(ND),RPAR(2)
        COMMON /INTERN/XOUT
        IF (NR.EQ.1) THEN
           WRITE (6,99) X,Y(1),Y(2),NR-1
           XOUT=X+2.0D0
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
              WRITE (6,99) XOUT,CONTD5(1,XOUT,CON,ICOMP,ND),
     &                     CONTD5(2,XOUT,CON,ICOMP,ND),NR-1
              XOUT=XOUT+2.0D0
              GOTO 10
           END IF
        END IF
 99     FORMAT(1X,'X =',F6.2,'    Y =',2E18.10,'    NSTEP =',I4)
        RETURN
        END
C
        SUBROUTINE FAREN(N,X,Y,F,RPAR,IPAR)
C --- ARENSTORF ORBIT
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),F(N),RPAR(2)
        AMU=RPAR(1)
        AMUP=RPAR(2)
        F(1)=Y(3)
        F(2)=Y(4)
        R1=(Y(1)+AMU)**2+Y(2)**2
        R1=R1*SQRT(R1)
        R2=(Y(1)-AMUP)**2+Y(2)**2
        R2=R2*SQRT(R2)
        F(3)=Y(1)+2*Y(4)-AMUP*(Y(1)+AMU)/R1-AMU*(Y(1)-AMUP)/R2
        F(4)=Y(2)-2*Y(3)-AMUP*Y(2)/R1-AMU*Y(2)/R2
        RETURN
        END


    subroutine func_fort(n,d)
        integer, intent(in) :: n
        double precision, intent(out) :: d
        integer :: i
        d = 0
        do i=0, n-1
            d = d + (mod(i,3) - 1) * i
        end do
    end subroutine func_fort


C$Procedure DVSEP ( Derivative of separation angle )

      DOUBLE PRECISION FUNCTION DVSEP( S1, S2 )

C$ Abstract
C
C     Calculate the time derivative of the separation angle between
C     two input states, S1 and S2.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     GEOMETRY
C     DERIVATIVES
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      S1 (6)
      DOUBLE PRECISION      S2 (6)

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     S1         I   State vector of the first body.
C     S2         I   State vector of the second body.
C
C$ Detailed_Input
C
C     S1         the state vector of the first target body as seen from
C                the observer.
C
C     S2         the state vector of the second target body as seen from
C                the observer.
C
C     An implicit assumption exists that both states lie in the same
C     reference frame with the same observer for the same epoch. If this
C     is not the case, the numerical result has no meaning.
C
C$ Detailed_Output
C
C     The function returns the double precision value of the time
C     derivative of the angular separation between S1 and S2.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     1) The routine in the call tree of this routine signal errors for
C        numeric overflow and underflow cases.
C
C     2) If called in RETURN mode, the return has value 0.
C
C     3) Linear dependent position components of S1 and S1 constitutes
C        a non-error exception. The function returns 0 for this case.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C     In this discussion, the notation
C
C        < V1, V2 >
C
C     indicates the dot product of vectors V1 and V2. The notation
C
C        V1 x V2
C
C     indicates the cross product of vectors V1 and V2.
C
C     To start out, note that we need consider only unit vectors,
C     since the angular separation of any two non-zero vectors
C     equals the angular separation of the corresponding unit vectors.
C     Call these vectors U1 and U2; let their velocities be V1 and V2.
C
C     For unit vectors having angular separation
C
C        THETA
C
C     the identity
C
C        || U1 x U1 || = ||U1|| * ||U2|| * sin(THETA)                (1)
C
C     reduces to
C
C        || U1 x U2 || = sin(THETA)                                  (2)
C
C     and the identity
C
C        | < U1, U2 > | = || U1 || * || U2 || * cos(THETA)           (3)
C
C     reduces to
C
C        | < U1, U2 > | = cos(THETA)                                 (4)
C
C     Since THETA is an angular separation, THETA is in the range
C
C        0 : Pi
C
C     Then letting s be +1 if cos(THETA) > 0 and -1 if cos(THETA) < 0,
C     we have for any value of THETA other than 0 or Pi
C
C
C                                  2          1/2
C        cos(THETA) = s * ( 1 - sin (THETA)  )                       (5)
C
C     or
C
C                                  2          1/2
C        < U1, U2 > = s * ( 1 - sin (THETA)  )                       (6)
C
C
C     At this point, for any value of THETA other than 0 or Pi,
C     we can differentiate both sides with respect to time (T)
C     to obtain
C
C                                                      2        -1/2
C        < U1, V2 > + < V1, U2 > =    s * (1/2)(1 - sin (THETA))
C
C                                   * (-2) sin(THETA)*cos(THETA)
C
C                                   * d(THETA)/dT                   (7a)
C
C
C     Using equation (5), and noting that s = 1/s, we can cancel
C     the cosine terms on the right hand side
C
C                                                      -1
C        < U1, V2 > + < V1, U2 > =    (1/2)(cos(THETA))
C
C                                   * (-2) sin(THETA)*cos(THETA)
C
C                                   * d(THETA)/dT                   (7b)
C
C     With (7b) reducing to
C
C        < U1, V2 > + < V1, U2 > = - sin(THETA) * d(THETA)/dT        (8)
C
C     Using equation (2) and switching sides, we obtain
C
C        || U1 x U2 || * d(THETA)/dT  =  - < U1, V2 > - < V1, U2 >   (9)
C
C     or, provided U1 and U2 are linearly independent,
C
C        d(THETA)/dT = ( - < U1, V2 > - < V1, U2 > ) / ||U1 x U2||  (10)
C
C     Note for times when U1 and U2 have angular separation 0 or Pi
C     radians, the derivative of angular separation with respect to
C     time doesn't exist. (Consider the graph of angular separation
C     with respect to time; typically the graph is roughly v-shaped at
C     the singular points.)
C
C$ Examples
C
C           PROGRAM DVSEP_T
C           IMPLICIT              NONE
C
C           DOUBLE PRECISION      ET
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      DSEPT
C           DOUBLE PRECISION      STATEE (6)
C           DOUBLE PRECISION      STATEM (6)
C
C           INTEGER               STRLEN
C           PARAMETER           ( STRLEN = 64 )
C
C           CHARACTER*(STRLEN)    BEGSTR
C
C           DOUBLE PRECISION      DVSEP
C
C     C
C     C     Load kernels.
C     C
C           CALL FURNSH ('standard.tm')
C
C     C
C     C     An arbitrary time.
C     C
C           BEGSTR = 'JAN 1 2009'
C           CALL STR2ET( BEGSTR, ET )
C
C     C
C     C     Calculate the state vectors sun to Moon, sun to earth at ET.
C     C
C     C
C           CALL SPKEZR ( 'EARTH', ET, 'J2000', 'NONE', 'SUN',
C          .               STATEE, LT)
C
C           CALL SPKEZR ( 'MOON', ET, 'J2000', 'NONE', 'SUN',
C          .               STATEM, LT)
C
C     C
C     C     Calculate the time derivative of the angular separation of
C     C     the earth and Moon as seen from the sun at ET.
C     C
C           DSEPT = DVSEP( STATEE, STATEM )
C           WRITE(*,*) 'Time derivative of angular separation: ', DSEPT
C
C           END
C
C   The program compiled on OS X with g77 outputs (radians/sec):
C
C      Time derivative of angular separation:   3.81211936E-09
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     E.D. Wright    (JPL)
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.0, 21-MAR-2014 (EDW)
C
C       Reimplemented algorithm using ZZDIV.
C
C-    SPICELIB Version 1.0.1, 15-MAR-2010 (EDW)
C
C       Trivial header format clean-up.
C
C-    SPICELIB Version 1.0.0, 31-MAR-2009 (EDW)
C
C-&

C$ Index_Entries
C
C   time derivative of angular separation
C
C-&

C
C     SPICELIB functions
C

      DOUBLE PRECISION      VDOT
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      ZZDIV

      LOGICAL               RETURN
      LOGICAL               VZERO

C
C     Local variables
C

      DOUBLE PRECISION      DENOM
      DOUBLE PRECISION      NUMR
      DOUBLE PRECISION      PCROSS (3)
      DOUBLE PRECISION      U1     (6)
      DOUBLE PRECISION      U2     (6)

      IF ( RETURN() ) THEN
         DVSEP = 0.D0
         RETURN
      END IF

      CALL CHKIN( 'DVSEP' )

C
C     Compute the unit vectors and corresponding time derivatives
C     for the input state vectors.
C
      CALL DVHAT( S1, U1 )
      CALL DVHAT( S2, U2 )

C
C     Calculate the cross product vector of U1 and U2. As both vectors
C     have magnitude one, the magnitude of the cross product equals
C     sin(THETA), with THETA the angle between S1 and S2.
C
      CALL VCRSS( U1(1), U2(1), PCROSS )

C
C     Handle the parallel and anti-parallel cases.
C
      IF ( VZERO(PCROSS) ) THEN

         DVSEP = 0.D0
         CALL CHKOUT( 'DVSEP' )
         RETURN

      END IF

C
C     Now calculate the time derivative of the angular separation
C     between S1 and S2.
C

C
C     Separately calculate the numerator and denominator.
C
      NUMR  = VDOT( U1(1), U2(4) ) + VDOT( U1(4), U2(1) )
      DENOM = VNORM(PCROSS)

C
C     ZZDIV checks for over- or underflow. Finite precision
C     arithmetic is a pain.
C
      DVSEP = ZZDIV( -NUMR, DENOM )

C
C     Return, the expectation exists that a FAILED() call
C     follows the DVSEP call.
C
      CALL CHKOUT( 'DVSEP' )

      RETURN
      END


! MODULE: pf_my_sweeper
! IMEX Sweeper for 2-D  example in spectral space:
module pf_my_sweeper
  use pf_mod_dtype
  use pf_mod_zndarray
  use pf_mod_imex_sweeper
  use pf_mod_fftpackage
  use pf_mod_solutions
  use pf_mod_zutils
  use pf_mod_fftops
  implicit none

  !>  extend the IMEX sweeper
  type, extends(pf_imex_sweeper_t) :: my_sweeper_t
     integer ::     nx
     ! fft object and differentiaton matrices
     type(pf_fft_t), pointer :: fft_tool
     type(pf_fft_ops_t), pointer :: fft_ops
     complex(pfdp), allocatable :: tmp(:,:) ! temp space for feval

     complex(pfdp), pointer :: p_tmp(:,:) ! Useful pointer

     !  Useful for making f_eval and f_comp generic
     class(pf_zndarray_t), pointer :: f_encap,rhs_encap,y_encap
     complex(pfdp),      pointer :: yvec(:,:), rhsvec(:,:), fvec(:,:)

   contains

     procedure :: f_eval       !  Computes the advection and diffusion terms
     procedure :: f_comp       !  Computes the advection and diffusion terms
     procedure :: initialize
     procedure :: initialize_tmp
     procedure :: destroy
  end type my_sweeper_t

contains

  subroutine initialize_tmp(this)
    class(my_sweeper_t), intent(inout) :: this

    integer :: istat
    allocate(this%tmp(this%nx,this%nx),STAT=istat)
    if (istat .ne. 0)  call pf_stop(__FILE__,__LINE__,'Allocate failed ',istat)
  end subroutine initialize_tmp

  ! The rest of the stuff is dimension independent
  include 'sweeper_include.f90'

end module pf_my_sweeper


!##############################################################################
!# Tutorial 008d: Create a 2x2 block system with Mass/Laplace, nonlinear coeff.
!##############################################################################

module tutorial008d

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock

  use scalarpde
  use derivatives
  use bilinearformevaluation
  use domainintegration
  use collection

  use matrixio

  implicit none
  private

  public :: start_tutorial008d

contains

  ! ***************************************************************************

!<subroutine>

  subroutine fcoeff_Matrix (rdiscretisationTrial,&
                rdiscretisationTest, rform, nelements, npointsPerElement,&
                Dpoints, IdofsTrial, IdofsTest, rdomainIntSubset,&
                Dcoefficients, rcollection)

  use basicgeometry
  use collection
  use domainintegration
  use scalarpde
  use spatialdiscretisation
  use triangulation
  use fsystem

!<description>
  ! This subroutine is called during the matrix assembly. It has to compute
  ! the coefficients in front of the terms of the bilinear form.
  !
  ! The routine accepts a set of elements and a set of points on these
  ! elements (cubature points) in real coordinates.
  ! According to the terms in the bilinear form, the routine has to compute
  ! simultaneously for all these points and all the terms in the bilinear form
  ! the corresponding coefficients in front of the terms.
!</description>

!<input>
  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.; trial space.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisationTrial

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.; test space.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisationTest

  ! The bilinear form which is currently being evaluated:
  type(t_bilinearForm), intent(in) :: rform

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  ! DIMENSION(dimension,npointsPerElement,nelements)
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTrial

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in test space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset
!</input>

!<inputoutput>
  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection
!</inputoutput>

!<output>
  ! A list of all coefficients in front of all terms in the bilinear form -
  ! for all given points on all given elements.
  !   DIMENSION(itermCount,npointsPerElement,nelements)
  ! with itermCount the number of terms in the bilinear form.
  real(DP), dimension(:,:,:), intent(out) :: Dcoefficients
!</output>

!</subroutine>

    ! local variables
    integer :: imatrixType
    real(DP) :: dx,dy
    integer :: ivt,iel

    ! The collection tells us what to assemble.
    imatrixType = rcollection%IquickAccess(1)

    select case (imatrixType)

    ! Mass matrix
    case (1)

      ! Loop over all points and elements. Return the function in each point
      do iel=1,nelements
        do ivt=1,npointsPerElement

          ! Point coordinates
          dx = Dpoints(1,ivt,iel)
          dy = Dpoints(2,ivt,iel)

          ! Initialise the coefficients
          Dcoefficients(1,ivt,iel) = 1.0_DP + 16.0_DP * dx * (1.0_DP-dx) * dy * (1.0_DP-dy)

        end do
      end do

    ! Laplace matrix
    case (2)

      ! Loop over all points and elements. Return the function in each point
      do iel=1,nelements
        do ivt=1,npointsPerElement

          ! Point coordinates
          dx = Dpoints(1,ivt,iel)
          dy = Dpoints(2,ivt,iel)

          ! Initialise the coefficients. Both the same.
          Dcoefficients(1,ivt,iel) = 1.0_DP + sin( SYS_PI * dx ) * sin( SYS_PI * dy )
          Dcoefficients(2,ivt,iel) = Dcoefficients(1,ivt,iel)

        end do
      end do

    end select

  end subroutine

  ! ***************************************************************************

  subroutine start_tutorial008d

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr

    type(t_matrixScalar) :: rtemplateMatrix
    type(t_matrixBlock) :: rmatrix

    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_bilinearForm) :: rform
    type(t_collection) :: rcollection
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 008d")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Create a block discretisation that encapsules
    ! two equations, both discretised with Q1.
    ! =================================

    ! Set up a Q1 discretisation
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Set up a block discretisation for two equations. Both equations are Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Create a 2x2 block matrix with
    ! entries in (1,1) and (2,2)
    ! =================================

    ! Create a template matrix for the FEM space. CSR structure.
    call bilf_createMatrixStructure (rspatialDiscr,LSYSSC_MATRIX9,rtemplateMatrix)

    ! Use the block discretisation to create a basic system matrix.
    call lsysbl_createMatrix (rblockDiscr,rmatrix)

    ! Create (1,1) and (2,2) using the template matrix.
    ! Structure is "shared" (no new memory is allocated), content is allocated.
    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,1,1,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    call lsysbl_duplicateMatrix (rtemplateMatrix,rmatrix,2,2,&
        LSYSSC_DUP_SHARE,LSYSSC_DUP_EMPTY)

    ! =================================
    ! Clear the matrix
    ! =================================

    call lsysbl_clearMatrix (rmatrix)

    ! =================================
    ! Use a 3-point Gauss Formula for the assembly
    ! =================================

    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Block (1,1): f Mass
    ! =================================

    ! Set up a bilinear for for Mass. There is 1 term...
    rform%itermCount = 1

    ! We have nonconstant coefficients
    rform%ballCoeffConstant = .false.

    ! Term 1/2: Mass  =>  (f phi, psi)
    rform%Idescriptors(1,1) = DER_FUNC2D
    rform%Idescriptors(2,1) = DER_FUNC2D

    ! Via the collection tell the callback routine to assemble Mass.
    rcollection%IquickAccess(1) = 1

    ! Build the matrix block (1,1)
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(1,1),rcubatureInfo,&
        fcoeff_Matrix, rcollection)

    ! =================================
    ! Block (2,2): g (-Laplace)
    ! =================================

    ! Set up a bilinear for for Laplace...
    rform%itermCount = 2

    ! We have nonconstant coefficients:
    rform%ballCoeffConstant = .false.

    ! Term 1/2: -Laplace  =>  (g phi_x, psi_x)  +  (g phi_y, psi_y)
    rform%Idescriptors(1,1) = DER_DERIV2D_X
    rform%Idescriptors(2,1) = DER_DERIV2D_X

    rform%Idescriptors(1,2) = DER_DERIV2D_Y
    rform%Idescriptors(2,2) = DER_DERIV2D_Y

    ! Via the collection tell the callback routine to assemble Laplace.
    rcollection%IquickAccess(1) = 2

    ! Build the matrix block (2,2)
    call bilf_buildMatrixScalar (rform,.false.,rmatrix%RmatrixBlock(2,2),rcubatureInfo,&
        fcoeff_Matrix, rcollection)

    ! =================================
    ! Output of the matrix
    ! =================================
    call output_line ("Writing matrix to text files...")

    if (sys_getenv_string("POSTDIR",spostdir)) then
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial008d_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          trim(spostdir)//"/tutorial008d_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          trim(spostdir)//"/tutorial008d_matrix.maple", "(E11.2)")
    else
      ! Write the matrix to a text file, omit nonexisting entries in the matrix.
      call matio_writeBlockMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial008d_matrix.txt", "(E11.2)")

      ! Write the matrix to a MATLAB file.
      call matio_spyBlockMatrix(&
          "./post/tutorial008d_matrix.m","matrix",rmatrix,.true.)

      ! Write the matrix to a MAPLE file
      call matio_writeBlockMatrixMaple (rmatrix, "matrix", 0, &
          "./post/tutorial008d_matrix.maple", "(E11.2)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the cubature formula
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the matrix
    call lsysbl_releaseMatrix (rmatrix)

    ! ... and the FEM template matrix
    call lsyssc_releaseMatrix (rtemplateMatrix)

    ! Release the block discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


module potential

use tensor

implicit none

public :: eval_potential, rmsd

contains

subroutine eval_potential(r_mol, moments, fit_order, r_mep, nmep, mom_pot)
implicit none

double precision, dimension(:,:), intent(in) :: r_mol
double precision, dimension(:), intent(in) :: moments
integer, intent(in) :: fit_order
double precision, dimension(:,:), intent(in) :: r_mep
integer, intent(in) :: nmep
double precision, dimension(:), intent(out) :: mom_pot

integer :: nat, iat, imep, vec_idx, quad_idx
double precision :: q
double precision, dimension(3) :: r_a, r_b, vec
double precision, dimension(6) :: quad

mom_pot = 0.0d0
nat = size(r_mol, 2)
do iat = 1, nat
  ! extract moments
  q = moments(iat)
  r_a = r_mol(:,iat)

  vec_idx = nat + 3*(iat-1)+1
  if (fit_order >= 1) then
    vec = moments(vec_idx:vec_idx+2)
  end if

  quad_idx = nat + 3 * nat + 6*(iat-1) + 1
  if (fit_order >= 2) then
    quad = moments(quad_idx:quad_idx+5)
  end if

  do imep = 1, nmep
    r_b = r_mep(:,imep)

    mom_pot(imep) = mom_pot(imep) + q * t0(r_b, r_a)
    if (fit_order >= 1) then
      mom_pot(imep) = mom_pot(imep) + dot_product(vec, t1(r_b, r_a))
    endif

    if (fit_order >= 2) then
      mom_pot(imep) = mom_pot(imep) + 0.5 * dot_product(quad, t2(r_b, r_a))
    endif
  enddo
enddo

end subroutine eval_potential

function rmsd(array, n) result(var)

double precision, dimension(:), intent(in) :: array
integer, intent(in) :: n
double precision :: var

double precision, dimension(n) :: dev
double precision :: mean

mean = sum(array) / n

!allocate(dev(n))
dev = array - mean
var = sqrt(sum(dev*dev) / n)
!deallocate(dev)

end function

end module potential


PROGRAM main

  USE mo_kind,    ONLY: dp
  USE mo_boxcox,  ONLY: boxcox, invboxcox, get_boxcox
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  LOGICAL :: isgood

  real(dp), dimension(20) :: dx  = (/ 4.86, 4.92, 3.37, 3.29, 4.43, 1.53, 3.76, 0.35, &
                                      1.73, 1.98, 4.26, 4.64, 2.88, 2.35, 8.35, 5.6 , &
                                      4.28,13.04, 8.94, 3.94 /)
  real(dp), dimension(20) :: dy, dyx
  real(dp)                :: dl

  Write(*,*) ''
  Write(*,*) 'Test mo_boxcox.f90'
  Write(*,*) ''
  Write(*,*) 'Lambda is  0.39050292804648679 in Python'
  Write(*,*) 'and        0.3889467523247853  in Fortran'

  ! Double precision
  Write(*,*) ''
  isgood = .true.
  dl = get_boxcox(dx)
  write(*,*) 'Dlambda: ', dl
  isgood = isgood .and. ((nint(1000._dp*dl)-389) == 0)
  dy  = boxcox(dx,dl)
  dyx = invboxcox(dy,dl)
  if (any(abs(dx-dyx) > 1000._dp*epsilon(1.0_dp))) isgood = .False.

  if (isgood) then
     write(*,*) 'mo_boxcox double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_boxcox double precision ', color('failed!', c_red)
  endif

  ! Single precision
  Write(*,*) ''
  write(*,*) 'This example is not converging in single precision.'

END PROGRAM main