!===============================================================================
!===============================================================================
MODULE radau_mod
  implicit none
  private
  type, public:: radau_t
  contains
    procedure, nopass:: init
  end type
  type(radau_t), public:: radau
CONTAINS

!===============================================================================
!===============================================================================
SUBROUTINE init (k,xi,wi)
!
!  Routine to return weights and abscissa points for Gauss-Radau
!  integration in the interval [a; b]. The transformation from
!  the inherent interval of [-1; 1] is performed via c and d.
!  The Radau integration differs from a normal Gauss integration,
!  in that one of the end-points are included.
!  The number of integration points, k, can be chosen between
!  1 and 10, and the order of the interpolating function is 2*k-1.
!
!  Update history:
!  ---------------
!  29.08.2006 Coded/RT
!  31.08.2006 Fixed single/double precision ambiguity and changed from
!             x=0 to x=1 being included as a node/RT
!  15.01.2007 Ported from F77 to F90/RT
!
!  Known bugs: Hardcoded whether to use upper (coded) or lower end-point
!              in the integration.
!
  implicit none
  integer, parameter:: kmax = 10
  integer::              k
  real, dimension(k)::  wi, xi
  real::                 a, b
  real(kind=8), dimension(55)::  xn = (/ &
          -1.00000000000000d0,                                      &!  1
          -1.00000000000000d0, .33333333333333d0,                   &!  2
          -1.00000000000000d0,-.28989794855663d0, .68989794855663d0,&!  3
          -1.00000000000000d0,-.57531892352169d0, .18106627111853d0,&!  4
            .82282408097459d0,                                      &
          -1.00000000000000d0,-.72048027131244d0,-.16718086473783d0,&!  5
            .44631397272376d0, .88579160777096d0,                   &
          -1.00000000000000d0,-.80292982840235d0,-.39092854670727d0,&!  6
            .12405037950522d0, .60397316425279d0, .92038028589707d0,&
          -1.00000000000000d0,-.85389134263949d0,-.53846772406011d0,&!  7
           -.11734303754309d0, .32603061943769d0, .70384280066303d0,&
            .94136714568042d0,                                      &
          -1.00000000000000d0,-.88747487892616d0,-.63951861652622d0,&!  8
           -.29475056577366d0, .09430725266111d0, .46842035443083d0,&
            .77064189367819d0, .95504122712258d0,                   &
          -1.00000000000000d0,-.91073208942006d0,-.71126748591571d0,&!  9
           -.42635048571114d0,-.09037336960685d0, .25613567083346d0,&
            .57138304120873d0, .81735278420041d0, .96444016970528d0,&
          -1.00000000000000d0,-.92748437423359d0,-.76384204242000d0,&! 10
           -.52564603037008d0,-.23623446939059d0, .07605919783798d0,&
            .38066484014473d0, .64776668767401d0, .85122522058160d0,&
            .97117518070224d0/)
  real(kind=8), dimension(55)::  wn = (/ &
           2.00000000000000d0,                                      &!  1
           0.50000000000000d0,1.50000000000005d0,                   &!  2
           0.22222222222222d0,1.02497165237682d0,0.75280612540100d0,&!  3
           0.12500000000000d0,0.65768863996010d0,0.77638693768637d0,&!  4
           0.44092442235367d0,                                      &
           0.08000000000000d0,0.44620780216715d0,0.62365304595145d0,&!  5
           0.56271203029887d0,0.28742712158247d0,                   &
           0.05555555555556d0,0.31964075322051d0,0.48538718846895d0,&!  6
           0.52092678318961d0,0.41690133431186d0,0.20158838525329d0,&
           0.04081632653061d0,0.23922748922532d0,0.38094987364422d0,&!  7
           0.44710982901453d0,0.42470377900601d0,0.31820423146727d0,&
           0.14898847111224d0,                                      &
           0.03125000000000d0,0.18535815480298d0,0.30413062064680d0,&!  8
           0.37651754538912d0,0.39157216745253d0,0.34701479563444d0,&
           0.24964790132996d0,0.11450881474417d0,                   &
           0.02469135802469d0,0.14765401904631d0,0.24718937820459d0,&!  9
           0.31684377567046d0,0.34827300277294d0,0.33769396697589d0,&
           0.28638669635730d0,0.20055329802460d0,0.09071450492309d0,&
           0.02000000000000d0,0.12029667055749d0,0.20427013187899d0,&! 10
           0.26819483784117d0,0.30585928772442d0,0.31358245722693d0,&
           0.29061016483286d0,0.23919343171435d0,0.16437601273700d0,&
           0.07361700548689d0/)
  integer, dimension(kmax+1):: k0 = (/1,2,4,7,11,16,22,29,37,46,56/)
  real c,d
  integer i

  a = 0.0
  b = 1.0
  if (k.lt.1) then
    print *,' WARNING(radaui): k=',k,'< 1 does not make sense!'
    print *,'                  Setting k=1.'
    k = 1
  endif
  if (k.gt.kmax) then
    print *,' WARNING(radaui): k=',k,'>',kmax,' is not implemented.'
    print *,'                  Setting k=',kmax,'.'
    k = kmax
  endif
  c = .5*(b+a)
  d = .5*(b-a)
!
! Loop through the number of points in the integration
  do i=1, k
!
! Using this form instead of [c + d*xn(k0(k)+i-1)] makes
! x=1 (or b) the predefined node instead of x=-1 (or a).
    xi(i) = 1.0 - (c + d*xn(k0(k+1)-i))
    wi(i) =            d*wn(k0(k+1)-i)
  enddo

  return
END SUBROUTINE

END MODULE radau_mod


      program integer_exponent
       integer a, b, c

       a = 2
       b = 2

       c = a ** b

       print *, c
      end


	FUNCTION PR_WVIS ( wmovis )
C************************************************************************
C* PR_WVIS								*
C*									*
C* This subroutine translates a WMO visibility code into visibility	*
C* in kilometers.							*
C*									*
C* REAL PR_WVIS ( WMOVIS )						*
C*									*
C* Input parameters:							*
C*	WMOVIS		REAL		WMO visibility code		*
C*									*
C* Output parameters:							*
C*	PR_WVIS		REAL		Visibility in km		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/88						*
C* K. Brill/NMC		12/90	Documentation				*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C* J. Wu/GSC            07/00   Moved INCLUDE 'ERMISS.FNC' before the   *
C*                              DATA statement                          *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		vis90 (10)
	INCLUDE		'ERMISS.FNC'
	DATA		vis90 / 0., .1, .2, .5, 1., 2., 4., 10., 20.,
     +				50. /
C*
C------------------------------------------------------------------------
	IF  ( ERMISS ( wmovis ) ) THEN
	    PR_WVIS = RMISSD
	  ELSE
C
C*	    Values between 0 - 50 translate into tenths of kilometers.
C
	    IF  ( ( wmovis .ge. 0. ) .and. ( wmovis .le. 50. ) ) THEN
		PR_WVIS = wmovis / 10.
C
C*		Values between 56 and 80 are 50 + whole kilometers.
C
	      ELSE IF ( ( wmovis .ge. 56. ) .and.
     +			( wmovis .le. 80. ) ) THEN
		PR_WVIS = wmovis - 50.
C
C*		Values from 81 - 89 are in increments of 5.
C
	      ELSE IF ( ( wmovis .ge. 81. ) .and.
     +			( wmovis .le. 89. ) ) THEN
		PR_WVIS = ( wmovis - 80. ) * 5. + 30.
C
C*		The values from 90 - 99 are in a data statement.
C
	      ELSE IF ( ( wmovis .ge. 90. ) .and.
     +			( wmovis .le. 99. ) ) THEN
		iknt = wmovis - 89
		PR_WVIS = vis90 ( iknt )
C
C*		Otherwise, return missing data.
C
	      ELSE
		PR_WVIS = RMISSD
	    END IF
	END IF
C*
	RETURN
	END


        subroutine iddr_rid(m,n,matvect,p1,p2,p3,p4,krank,list,proj)
c
c       computes the ID of a matrix "a" specified by
c       the routine matvect -- matvect must apply the transpose
c       of the matrix being ID'd to an arbitrary vector --
c       i.e., the present routine lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                       min(m,n,krank)
c       a(j,list(k))  =     Sigma      a(j,list(l)) * proj(l,k-krank)(*)
c                            l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c
c       input:
c       m -- number of rows in the matrix to be ID'd
c       n -- number of columns in the matrix to be ID'd
c       matvect -- routine which applies the transpose
c                  of the matrix to be ID'd to an arbitrary vector;
c                  this routine must have a calling sequence
c                  of the form
c
c                  matvect(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the transpose
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the transposed matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvect
c       p2 -- parameter to be passed to routine matvect
c       p3 -- parameter to be passed to routine matvect
c       p4 -- parameter to be passed to routine matvect
c       krank -- rank of the ID to be constructed
c
c       output:
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               proj doubles as a work array in the present routine, so
c               proj must be at least m+(krank+3)*n real*8 elements
c               long
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least m+(krank+3)*n real*8 elements
c               long.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr
        real*8 p1,p2,p3,p4,proj(m+(krank+3)*n)
        external matvect
c
c
c       Allocate memory in w.
c
        lw = 0
c
        ir = lw+1
        lr = (krank+2)*n
        lw = lw+lr
c
        ix = lw+1
        lx = m
        lw = lw+lx
c
        iy = lw+1
        ly = n
        lw = lw+ly
c
c
        call iddr_ridall0(m,n,matvect,p1,p2,p3,p4,krank,
     1                    list,proj(ir),proj(ix),proj(iy))
c
c
        return
        end
c
c
c
c


program ej1

  !Programa que determina el tipo de triángulo dados sus catetos.

  integer a, b, c

  print *, "Porfavor escribe los 3 lados que describen tu triángulo:"
  read(*,*) a, b, c !Leemos de la entrada estándar el valor de los tres enteros.

  if (a*b + b*c .eq. a*c) then
    print *, "No existe triángulo que determine A, B y C."

    return
  end if

  if ((a .eq. b) .and. (a .eq. c) .and. (b .eq. c)) then
    print *, "Es un triángulo equilatero."

  end if

  if (((a .eq. b) .and. (a .ne. c)) .or. &
  ((a .eq. c) .and. (a .ne. b)) .or. &
  ((b .eq. c) .and. (c .ne. a))) then
    print *, "Es un triángulo isóceles."

  end if

  if ((a.ne.b) .and. (b.ne.c) .and. (a.ne.c)) then
    print *, "Es un triángulo escaleno."

  end if

end program ej1


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer :: a, b, m
    common /group1/ a, b, m
    integer :: i
    integer, parameter :: num_pt = 20000000
    real(dp) :: x(num_pt), y(num_pt)
    real(dp) :: chi, chi_alpha

    interface
        function Schrage_16807(seed_)
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            integer, intent(in), optional :: seed_
            real(dp) :: Schrage_16807
        end function Schrage_16807

        function Chi_square(x, y, num_split_)
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in) :: x(:), y(:) ! x, y 坐标
            integer, intent(in), optional :: num_split_
            real(dp) :: Chi_square
        end function Chi_square

        function Chi_alpha_square(nu_, alpha_)
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            integer, optional :: nu_ ! 自由度
            real(dp), intent(in), optional :: alpha_ ! 显著水平
            real(dp) :: Chi_alpha_square
        end function Chi_alpha_square
    end interface

    a = 7**5
    b = 0
    m = 2**31 - 1
    do  i = 1, num_pt
        x(i) = Schrage_16807()
        y(i) = Schrage_16807()
    end do
    open(unit=11, file='1.1.1.3-Schrage-Method-1.txt', status='replace')
    do i = 1, 10000
        write(11, '(2f16.8)') x(i), y(i)
    end do
    close(11)

    chi = sqrt(Chi_square(x, y))
    chi_alpha = sqrt(Chi_alpha_square())

    write(*,*) 'chi = ', chi
    write(*,*) 'chi_alpha = ', chi_alpha
    if (chi < chi_alpha) then
        write(*,*) 'The random number series are uniformly distributed over [0,1).'
    else
        write(*,*) 'The random number series are not uniformly distributed over [0,1).'
    end if

    a = 106
    b = 1288
    m = 6075
    x(1) = Schrage_16807(1)
    y(1) = Schrage_16807()
    do  i = 2, num_pt
        x(i) = Schrage_16807()
        y(i) = Schrage_16807()
    end do
    open(unit=11, file='1.1.1.3-Schrage-Method-2.txt', status='replace')
    do i = 1, 10000
        write(11, '(2f16.8)') x(i), y(i)
    end do
    close(11)

    chi = sqrt(Chi_square(x, y))
    chi_alpha = sqrt(Chi_alpha_square())

    write(*,*) 'chi = ', chi
    write(*,*) 'chi_alpha = ', chi_alpha
    if (chi < chi_alpha) then
        write(*,*) 'The random number series are uniformly distributed over [0,1).'
    else
        write(*,*) 'The random number series are not uniformly distributed over [0,1).'
    end if
end program main

function Schrage_16807(seed_)
    ! Schrage 方法实现 16807 产生器
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer, intent(in), optional :: seed_
    real(dp) :: Schrage_16807

    integer :: a, b, m
    common /group1/ a, b, m
    integer :: q, r
    integer, save :: z = -1

    q = m / a
    r = mod(m, a)
    if (present(seed_)) then
        z = seed_
    else if (z == -1) then
        z = 1
    end if
    z = a * mod(z, q) - r * (z / q)
    if (z < 0) then
        z = z + m
    end if
    z = z + b
    if (z >= m) then
        z = z - m
    end if
    Schrage_16807 = z / dble(m)
end function Schrage_16807

function Chi_square(x, y, num_split_)
    ! 统计量 chi^2
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp), intent(in) :: x(:), y(:) ! x, y 坐标
    integer, intent(in), optional :: num_split_ ! x, y 方向上各分割成 num_split 个区间
    real(dp) :: Chi_square

    integer :: i, j
    integer :: num_split
    integer, allocatable :: n(:) ! 实际频数
    real(dp) :: m ! 理论频数

    num_split = 10
    if (present(num_split_)) then
        num_split = num_split_
    end if
    allocate(n(num_split**2))

    m = size(x) / dble(num_split**2)

    do i = 1, num_split
        do j = 1, num_split
            n((i - 1) * num_split + j) = count((((i-1) / dble(num_split)) <= x) .and. (x < (i / dble(num_split))) .and.&
            (((j - 1) / dble(num_split)) <= y) .and. (y < (j / dble(num_split))))
        end do
    end do

    Chi_square = sum((n - m)**2 / dble(m))
end function Chi_square

function Chi_alpha_square(nu_, alpha_)
    ! chi_alpha^2
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer, optional :: nu_ ! 自由度
    real(dp), intent(in), optional :: alpha_ ! 显著水平
    real(dp) :: Chi_alpha_square

    integer :: nu
    real(dp) :: P_fiducial ! 置信概率
    integer :: i
    real(dp) :: x_lower_bound = 0.d0, x_upper_bound = 1.d0

    nu = 99
    if (present(nu_)) then
        nu = nu_
    end if
    P_fiducial = 0.95
    if (present(alpha_)) then
        P_fiducial = 1.d0 - alpha_
    end if

    do while (.not. ((P_chi_square(x_lower_bound, nu) <= P_fiducial) .and. (P_chi_square(x_upper_bound, nu) > P_fiducial)))
        x_lower_bound = x_upper_bound
        x_upper_bound = 2.d0 * x_upper_bound
    end do
    do i = 1, 10
        if ((P_chi_square((x_lower_bound + x_upper_bound) / 2.d0, nu) <= P_fiducial)) then
            x_lower_bound = (x_lower_bound + x_upper_bound) / 2.d0
        else
            x_upper_bound = (x_lower_bound + x_upper_bound) / 2.d0
        end if
    end do
    Chi_alpha_square = (x_lower_bound + x_upper_bound) / 2.d0

    contains
        function P_chi_square(x, nu, num_pt_)
            ! chi^2 分布的累计分布函数，其中积分项利用 Simpson 法计算
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in) :: x
            integer, intent(in) :: nu
            integer, optional :: num_pt_ ! 必须为奇数
            real(dp) :: P_chi_square

            integer :: num_pt, num_sect
            real(dp) :: dx
            real(dp), allocatable :: integrand(:)
            integer :: i

            if (x == 0.d0) then
                P_chi_square = 0.0
                return
            end if
            if (.not. (present(num_pt_))) then
                num_pt = 101
            else if (mod(num_pt_, 2) == 0) then
                write(*,*) 'Even elements, Simpson does not know how to work!'
                P_chi_square = 0.0
                return
            end if
            num_sect = num_pt - 1
            dx = x / dble(num_sect)
            allocate(integrand(0:num_sect))

            integrand = [((i * dx)**((nu - 2) / 2.d0) * exp(-i * dx / 2.d0),&
                i=0, num_sect)]

            P_chi_square = P_chi_square + integrand(0) + integrand(num_sect)
            P_chi_square = P_chi_square + 4.d0 * sum(integrand(1:num_sect - 1:2))
            P_chi_square = P_chi_square + 2.d0 * sum(integrand(2:num_sect - 2:2))
            P_chi_square = P_chi_square * dx / 3.d0
            P_chi_square = P_chi_square / 2**(nu / 2.d0) / Gamma(nu / 2.d0)
        end function P_chi_square
end function Chi_alpha_square


  subroutine funct(n,m,x,eps,f)

  implicit none

  integer n,m,i
  real*8 x(n),f,fob,fmax
  real*8 constr(m), eps(m)

  call fobcon(n,m,x,fob,constr)

  fmax = 0.d0

  do i = 1,m
    fmax = fmax + (max(0.d0,constr(i))**1.1d0)/eps(i)
  enddo

  f = fob + fmax

  return
  end


PROGRAM type_pointer
IMPLICIT NONE
TYPE fun
  INTEGER :: int
  CHARACTER :: char
END TYPE fun
INTEGER :: i
INTEGER, PARAMETER :: MAX_SIZE = 30
INTEGER, DIMENSION(MAX_SIZE), TARGET :: nums
INTEGER, POINTER :: p
TYPE(fun), DIMENSION(MAX_SIZE), TARGET :: fun_stuff
TYPE(fun), POINTER :: fsp

p => nums(3)
fsp => fun_stuff(5)

DO i = 1, MAX_SIZE
  fun_stuff(i)%int = i
  fun_stuff(i)%char = ACHAR(MOD(i - 1, 25) + 65)
  nums(i) = 2 * i - 1
END DO

WRITE(*, *) p, fsp%char
p = 12
fsp%char = '@'

DO i = 1, MAX_SIZE
  WRITE(*, '(2I4,A3)') nums(i), fun_stuff(i)%int, fun_stuff(i)%char
END DO

END PROGRAM type_pointer


! { dg-do compile }
! Tests the fix for PR29060 in which the shape of the result
! of SPREAD was not available to the scalarizer.
!
! Contributed by Paul Thomas  <pault@gcc.gnu.org>
  real,dimension(:, :),pointer :: ptr
  real,dimension(2, 2) :: u

  u = reshape((/0.25, 0.5, 0.75, 1.00/),(/2,2/))

  allocate (ptr(2,2))

! Original PR
  ptr(:, :) = u + spread ((/1.0, 2.0/), 2, size(u, 2))
  if (any (ptr .ne. &
        reshape ((/1.25, 2.50, 1.75, 3.00/), (/2, 2/)))) STOP 1

! Check that the fix works correctly with the source shape after ncopies
  ptr(:, :) = u + spread ((/2.0, 3.0/), 1, size (u, 1))
  if (any (ptr .ne. &
        reshape ((/2.25, 2.50, 3.75, 4.00/), (/2,2/)))) STOP 2
end


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE MXIDEN(N,MAT)
      REAL MAT(N,*)

      IF (N .EQ. 4) THEN
        MAT(1,1) = 1.0
        MAT(1,2) = 0.0
        MAT(1,3) = 0.0
        MAT(1,4) = 0.0

        MAT(2,1) = 0.0
        MAT(2,2) = 1.0
        MAT(2,3) = 0.0
        MAT(2,4) = 0.0

        MAT(3,1) = 0.0
        MAT(3,2) = 0.0
        MAT(3,3) = 1.0
        MAT(3,4) = 0.0

        MAT(4,1) = 0.0
        MAT(4,2) = 0.0
        MAT(4,3) = 0.0
        MAT(4,4) = 1.0
      ELSE
        DO 2930 I = 1,N
          DO 2950 J = 1,N
            MAT(I,J) = 0.
 2950     CONTINUE
 2930   CONTINUE
        DO 2970 I = 1,N
          MAT(I,I) = 1.
 2970   CONTINUE
      end if
      RETURN

      END


module trafficlib

  use unirand
  use mplib

  implicit none

  integer, parameter :: seed = 5743

contains

integer function initroad(road, n, density, seedval)

  integer :: n, seedval
  integer :: road(n)
  real    :: density

  integer :: i, ncar
  real    :: rng

  call rinit(seedval)

  ncar = 0

  do i = 1, n

     rng = uni()

     if (rng .lt. density) then

        road(i) = 1

     else

        road(i) = 0

     end if

     ncar = ncar + road(i)

  end do

  initroad = ncar

end function initroad

integer function updateroad(newroad, oldroad, n)

  integer :: n
  integer :: newroad(0:n+1), oldroad(0:n+1)

  integer :: i, nmove

  nmove = 0

  do i = 1, n

     if (oldroad(i) .eq. 1) then

        if (oldroad(i+1) .eq. 1) then

           newroad(i) = 1

        else

           newroad(i) = 0
           nmove = nmove + 1

        end if

     else

        if (oldroad(i-1) .eq. 1) then

           newroad(i) = 1

        else

           newroad(i) = 0

        end if

     end if

  end do

  updateroad = nmove

end function updateroad

subroutine updatebcs(road, n)

  integer :: n
  integer :: road(0:n+1)

  road(0)   = road(n)
  road(n+1) = road(1)

end subroutine updatebcs

subroutine mpupdatebcs(road, n, procid, nproc)

  integer :: n, procid, nproc
  integer :: road(0:n+1)

  integer procup, procdown

  procup   = mod(procid + 1, nproc)
  procdown = mod(procid + nproc - 1, nproc)

  call mpsendrecv(road(n), procup,   road(0),   procdown)
  call mpsendrecv(road(1), procdown, road(n+1), procup  )

end subroutine mpupdatebcs

end module trafficlib


      implicit none
      integer ns,nt
      double precision, allocatable :: source(:,:),targ(:,:)
      double precision, allocatable :: charge(:)
      double precision, allocatable :: dipvec(:,:)
      double precision, allocatable :: pot(:),pottarg(:)
      double precision, allocatable :: grad(:,:),gradtarg(:,:)
      double precision, allocatable :: hess(:,:),hesstarg(:,:)

      double precision eps
      double complex eye
      integer i,j,k,ntest,ier
      integer ifcharge,ifdipole,ifpgh,ifpghtarg
      double precision err,hkrand
      integer ipass(27),len1,ntests,isum
      character(len=100) str1

      data eye/(0.0d0,1.0d0)/

c
cc      initialize printing routine
c
      call prini(6,13)

      ns = 5000
      nt = 4999

      ntest = 20

      allocate(source(3,ns),targ(3,nt))
      allocate(charge(ns),dipvec(3,ns))
      allocate(pot(ns))
      allocate(grad(3,ns))
      allocate(hess(6,ns))

      allocate(pottarg(nt))
      allocate(gradtarg(3,nt))
      allocate(hesstarg(6,nt))

      eps = 0.51d-3

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

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

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

c
cc      generate sources uniformly in the unit cube
c
c
      do i=1,ns
        source(1,i) = hkrand(0)**2
        source(2,i) = hkrand(0)**2
        source(3,i) = hkrand(0)**2

        charge(i) = hkrand(0)

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

        pot(i) = 0
        grad(1,i) = 0
        grad(2,i) = 0
        grad(3,i) = 0
      enddo

c
cc      generate targets uniformly in the unit cube
c
      do i=1,nt
        targ(1,i) = hkrand(0)
        targ(2,i) = hkrand(0)
        targ(3,i) = hkrand(0)

        pottarg(i) = 0
        gradtarg(1,i) = 0
        gradtarg(2,i) = 0
        gradtarg(3,i) = 0
      enddo

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

       call lfmm3d_s_c_p(eps,ns,source,charge,pot,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 1
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

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

c

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

       call lfmm3d_s_c_g(eps,ns,source,charge,
     1      pot,grad,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 2
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(2) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_d_p(eps,ns,source,dipvec,
     1      pot,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 1
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(3) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_d_g(eps,ns,source,dipvec,
     1      pot,grad,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 2
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(4) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_cd_p(eps,ns,source,charge,dipvec,
     1      pot,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 1
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(5) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_cd_g(eps,ns,source,charge,dipvec,
     1      pot,grad,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 2
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

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

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

       call lfmm3d_t_c_p(eps,ns,source,charge,
     1      nt,targ,pottarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 0
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(7) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_c_g(eps,ns,source,charge,
     1      nt,targ,pottarg,gradtarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 0
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(8) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_d_p(eps,ns,source,dipvec,
     1      nt,targ,pottarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(9) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_d_g(eps,ns,source,dipvec,
     1      nt,targ,pottarg,gradtarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(10) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_cd_p(eps,ns,source,charge,dipvec,
     1      nt,targ,pottarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(11) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_cd_g(eps,ns,source,charge,dipvec,
     1      nt,targ,pottarg,gradtarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(12) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_c_p(eps,ns,source,charge,
     1      pot,nt,targ,pottarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 1
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(13) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_c_g(eps,ns,source,charge,
     1      pot,grad,nt,targ,pottarg,gradtarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 2
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(14) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_d_p(eps,ns,source,dipvec,
     1      pot,nt,targ,pottarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 1
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(15) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_d_g(eps,ns,source,dipvec,
     1      pot,grad,nt,targ,pottarg,gradtarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 2
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(16) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_cd_p(eps,ns,source,charge,dipvec,
     1      pot,nt,targ,pottarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 1
       ifpghtarg = 1

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(17) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_cd_g(eps,ns,source,charge,dipvec,
     1      pot,grad,nt,targ,pottarg,gradtarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 2
       ifpghtarg = 2

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(18) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_c_h(eps,ns,source,charge,
     1      pot,grad,hess,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 3
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(19) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_d_h(eps,ns,source,dipvec,
     1      pot,grad,hess,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 3
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(20) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_s_cd_h(eps,ns,source,charge,dipvec,
     1      pot,grad,hess,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 3
       ifpghtarg = 0

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(21) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_c_h(eps,ns,source,charge,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 0
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(22) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_d_h(eps,ns,source,dipvec,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(23) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_t_cd_h(eps,ns,source,charge,dipvec,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 0
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(24) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_c_h(eps,ns,source,charge,pot,grad,hess,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 1
       ifdipole = 0
       ifpgh = 3
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(25) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_d_h(eps,ns,source,dipvec,pot,grad,hess,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 0
       ifdipole = 1
       ifpgh = 3
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(26) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.ge.eps) write(33,*) str1(1:len1)

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

       call lfmm3d_st_cd_h(eps,ns,source,charge,dipvec,pot,grad,hess,
     1      nt,targ,pottarg,gradtarg,hesstarg,ier)

       ifcharge = 1
       ifdipole = 1
       ifpgh = 3
       ifpghtarg = 3

       call comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

       call prin2('l2 rel err=*',err,1)
       write(6,*)
       write(6,*)
       write(6,*) '================'
      if(err.lt.eps) ipass(27) = 1
      call geterrstr(ifcharge,ifdipole,ifpgh,ifpghtarg,str1,len1)
      if(err.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 lfmm3d testing suite'
      write(33,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in lfmm3d testing suite'
      close(33)

      stop
      end
c----------------------------------------------------------
c
cc
c
c
c
c
      subroutine comperr(ns,source,ifcharge,charge,ifdipole,
     1   dipvec,ifpgh,pot,grad,hess,nt,targ,ifpghtarg,pottarg,gradtarg,
     2   hesstarg,ntest,err)

      implicit none
      double complex zk
      integer ns,nt,ifcharge,ifdipole,ifpgh,ifpghtarg

      double precision source(3,*),targ(3,*)
      double precision dipvec(3,*)
      double precision charge(*)

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

      integer i,j,ntest,nd,l

      double precision err,ra

      double precision potex(ntest),gradex(3,ntest),pottargex(ntest),
     1                  gradtargex(3,ntest)
      double precision hessex(6,ntest),hesstargex(6,ntest)

      double precision thresh

      nd = 1
      err = 0
      do i=1,ntest
        potex(i) = 0
        pottargex(i) = 0

        gradex(1,i) = 0
        gradex(2,i) = 0
        gradex(3,i) = 0

        gradtargex(1,i) = 0
        gradtargex(2,i) = 0
        gradtargex(3,i) = 0

        do j=1,6
          hessex(j,i) = 0
          hesstargex(j,i) = 0
        enddo
      enddo

      thresh = 1.0d-16

      if(ifcharge.eq.1.and.ifdipole.eq.0) then
        if(ifpgh.eq.1) then
          call l3ddirectcp(nd,source,charge,ns,source,ntest,
     1       potex,thresh)
        endif

        if(ifpgh.eq.2) then
          call l3ddirectcg(nd,source,charge,ns,source,ntest,
     1       potex,gradex,thresh)
        endif

        if(ifpgh.eq.3) then
          call l3ddirectch(nd,source,charge,ns,source,ntest,
     1       potex,gradex,hessex,thresh)
        endif

        if(ifpghtarg.eq.1) then
          call l3ddirectcp(nd,source,charge,ns,targ,ntest,
     1       pottargex,thresh)
        endif

        if(ifpghtarg.eq.2) then
          call l3ddirectcg(nd,source,charge,ns,targ,ntest,
     1       pottargex,gradtargex,thresh)
        endif

        if(ifpghtarg.eq.3) then
          call l3ddirectch(nd,source,charge,ns,targ,ntest,
     1       pottargex,gradtargex,hesstargex,thresh)
        endif
      endif

      if(ifcharge.eq.0.and.ifdipole.eq.1) then
        if(ifpgh.eq.1) then
          call l3ddirectdp(nd,source,dipvec,
     1      ns,source,ntest,potex,thresh)
        endif

        if(ifpgh.eq.2) then
          call l3ddirectdg(nd,source,dipvec,
     1       ns,source,ntest,potex,gradex,thresh)
        endif

        if(ifpgh.eq.3) then
          call l3ddirectdh(nd,source,dipvec,
     1       ns,source,ntest,potex,gradex,hessex,thresh)
        endif

        if(ifpghtarg.eq.1) then
          call l3ddirectdp(nd,source,dipvec,
     1       ns,targ,ntest,pottargex,thresh)
        endif

        if(ifpghtarg.eq.2) then
          call l3ddirectdg(nd,source,dipvec,
     1       ns,targ,ntest,pottargex,gradtargex,thresh)
        endif

        if(ifpghtarg.eq.3) then
          call l3ddirectdh(nd,source,dipvec,
     1       ns,targ,ntest,pottargex,gradtargex,hesstargex,thresh)
        endif
      endif

      if(ifcharge.eq.1.and.ifdipole.eq.1) then
        if(ifpgh.eq.1) then
          call l3ddirectcdp(nd,source,charge,dipvec,
     1      ns,source,ntest,potex,thresh)
        endif

        if(ifpgh.eq.2) then
          call l3ddirectcdg(nd,source,charge,dipvec,
     1       ns,source,ntest,potex,gradex,thresh)
        endif

        if(ifpgh.eq.3) then
          call l3ddirectcdh(nd,source,charge,dipvec,
     1       ns,source,ntest,potex,gradex,hessex,thresh)
        endif

        if(ifpghtarg.eq.1) then
          call l3ddirectcdp(nd,source,charge,dipvec,
     1       ns,targ,ntest,pottargex,thresh)
        endif

        if(ifpghtarg.eq.2) then
          call l3ddirectcdg(nd,source,charge,dipvec,
     1       ns,targ,ntest,pottargex,gradtargex,thresh)
        endif

        if(ifpghtarg.eq.3) then
          call l3ddirectcdh(nd,source,charge,dipvec,
     1       ns,targ,ntest,pottargex,gradtargex,hesstargex,thresh)
        endif
      endif

      err = 0
      ra = 0

      if(ifpgh.eq.1) then
        do i=1,ntest
          ra = ra + abs(potex(i))**2
          err = err + abs(pot(i)-potex(i))**2
        enddo
      endif

      if(ifpgh.eq.2) then
        do i=1,ntest
          ra = ra + abs(potex(i))**2
          ra = ra + abs(gradex(1,i))**2
          ra = ra + abs(gradex(2,i))**2
          ra = ra + abs(gradex(3,i))**2

          err = err + abs(pot(i)-potex(i))**2
          err = err + abs(grad(1,i)-gradex(1,i))**2
          err = err + abs(grad(2,i)-gradex(2,i))**2
          err = err + abs(grad(3,i)-gradex(3,i))**2
        enddo
      endif

      if(ifpgh.eq.3) then
        do i=1,ntest
          ra = ra + abs(potex(i))**2
          ra = ra + abs(gradex(1,i))**2
          ra = ra + abs(gradex(2,i))**2
          ra = ra + abs(gradex(3,i))**2
          do l=1,6
            ra = ra + abs(hessex(l,i))**2
          enddo

          err = err + abs(pot(i)-potex(i))**2
          err = err + abs(grad(1,i)-gradex(1,i))**2
          err = err + abs(grad(2,i)-gradex(2,i))**2
          err = err + abs(grad(3,i)-gradex(3,i))**2
          do l=1,6
            err = err + abs(hess(l,i)-hessex(l,i))**2
          enddo
        enddo
      endif

      if(ifpghtarg.eq.1) then
        do i=1,ntest
          ra = ra + abs(pottargex(i))**2
          err = err + abs(pottarg(i)-pottargex(i))**2
        enddo
      endif

      if(ifpghtarg.eq.2) then
        do i=1,ntest
          ra = ra + abs(pottargex(i))**2
          ra = ra + abs(gradtargex(1,i))**2
          ra = ra + abs(gradtargex(2,i))**2
          ra = ra + abs(gradtargex(3,i))**2

          err = err + abs(pottarg(i)-pottargex(i))**2
          err = err + abs(gradtarg(1,i)-gradtargex(1,i))**2
          err = err + abs(gradtarg(2,i)-gradtargex(2,i))**2
          err = err + abs(gradtarg(3,i)-gradtargex(3,i))**2
        enddo
      endif

      if(ifpghtarg.eq.3) then
        do i=1,ntest
          ra = ra + abs(pottargex(i))**2
          ra = ra + abs(gradtargex(1,i))**2
          ra = ra + abs(gradtargex(2,i))**2
          ra = ra + abs(gradtargex(3,i))**2

          do l=1,6
            ra = ra + abs(hesstargex(l,i))**2
          enddo

          err = err + abs(pottarg(i)-pottargex(i))**2
          err = err + abs(gradtarg(1,i)-gradtargex(1,i))**2
          err = err + abs(gradtarg(2,i)-gradtargex(2,i))**2
          err = err + abs(gradtarg(3,i)-gradtargex(3,i))**2
          do l=1,6
            err = err + abs(hesstarg(l,i)-hesstargex(l,i))**2
          enddo
        enddo
      endif

      err = sqrt(err/ra)
      return
      end

c
c
c
c


! Copyright (c) 2021 Steffen Richters-Finger
! ETDRK4:
! Cox, Steven M., and Paul C. Matthews. "Exponential time differencing for stiff systems." Journal of Computational Physics 176.2, 430-455 (2002).
! Kassam, Aly-Khan, and Lloyd N. Trefethen. "Fourth-order time-stepping for stiff PDEs." SIAM Journal on Scientific Computing 26.4 1214-1233 (2005).
module ETDRK4
	use FFTW2d
	use, intrinsic :: iso_c_binding
	implicit none

	type(C_PTR) :: p
	complex(C_DOUBLE_COMPLEX), pointer :: ctemp(:, :), freq_partialx(:, :), freq_partialy(:, :)
	real(C_DOUBLE), pointer :: rtemp(:, :), real_partialx(:, :), real_partialy(:, :)

	integer (kind = 8) :: fftw_plan_freq_partialx, fftw_plan_freq_partialy, fftw_plan_rtemp

	integer :: nx, ny
	real( kind = 8 ) :: dtime, Lx, Ly

	! model-specific parameters
	real( kind = 8 ), allocatable :: controlparam(:)
	integer :: modelid = -1

	integer, allocatable :: karrayx(:)
	integer, allocatable :: karrayy(:)
	integer, parameter :: Ncontourintegral = 64
	real (kind = 8), allocatable :: qarray(:, :), derivx(:, :), derivy(:, :)
	complex (kind = 8), allocatable :: a0(:, :), a1(:, :), a2(:, :), a3(:, :), a4(:, :)
	real(kind = 8) :: time
	real(kind = 8), allocatable :: real_data(:, :)
	complex(kind = 8), allocatable :: freq_data(:, :)

contains
	! initialize the module with a time step, system size information, number of samples, model identifier, and an array of control parameters
	subroutine initETDRK4( dtime0, Lx0, Ly0, nx0, ny0, modelid0, controlparam0 )
		real (kind = 8) :: dtime0, Lx0, Ly0
		character (*) :: modelid0
		real (kind = 8) :: controlparam0(:)
		integer :: ix, iy, nx0, ny0
		real(C_DOUBLE), pointer :: arr(:,:)

		! save parameters
		dtime = dtime0
		Lx = Lx0
		Ly = Ly0
		nx = nx0
		ny = ny0
		select case (modelid0)
		case ('KSE') ! damped Kuramoto-Sivashinsky equation (KSE), parameter controls damping
			modelid = 0
		case ('NE') ! damped Nikolaevskiy equation (NE), parameters control damping + drive
			modelid = 1
		case default
			write(*,*) 'model abbreviation', modelid0, ' not recognized'
			modelid = -1
		end select
		allocate(controlparam(size(controlparam0(:))))
		controlparam = controlparam0

		time = 0.0d0

		! allocate memory
		allocate(real_data(nx, ny))
		allocate(freq_data(nx/2 + 1, ny))
		allocate(a0(nx/2 + 1, ny))
		allocate(a1(nx/2 + 1, ny))
		allocate(a2(nx/2 + 1, ny))
		allocate(a3(nx/2 + 1, ny))
		allocate(a4(nx/2 + 1, ny))
		allocate(karrayx(nx/2 + 1))
		allocate(karrayy(ny))
		allocate(qarray(nx/2 + 1, ny))
		allocate(derivx(nx/2 + 1, ny))
		allocate(derivy(nx/2 + 1, ny))

		! allocate aligned memory (increased performance of FFTW)
  		p = fftw_alloc_real(int(nx * ny, C_SIZE_T))
  		call c_f_pointer(p, rtemp, [nx, ny])
  		p = fftw_alloc_real(int(nx * ny, C_SIZE_T))
  		call c_f_pointer(p, real_partialx, [nx, ny])
  		p = fftw_alloc_real(int(nx * ny, C_SIZE_T))
  		call c_f_pointer(p, real_partialy, [nx, ny])
		p = fftw_alloc_complex(int((nx/2 + 1) * ny, C_SIZE_T))
		call c_f_pointer(p, ctemp, [nx/2 + 1, ny])
		p = fftw_alloc_complex(int((nx/2 + 1) * ny, C_SIZE_T))
		call c_f_pointer(p, freq_partialx, [nx/2 + 1, ny])
		p = fftw_alloc_complex(int((nx/2 + 1) * ny, C_SIZE_T))
		call c_f_pointer(p, freq_partialy, [nx/2 + 1, ny])

		! make FFTW plans
		! note: fftw-c2r plans destroy input array data
		call dfftw_plan_dft_c2r_2d(fftw_plan_freq_partialx, &
					nx, ny, freq_partialx, real_partialx, FFTW_ESTIMATE )
		call dfftw_plan_dft_c2r_2d(fftw_plan_freq_partialy, &
					nx, ny, freq_partialy, real_partialy, FFTW_ESTIMATE )
		call dfftw_plan_dft_r2c_2d(fftw_plan_rtemp, nx, ny, rtemp, ctemp, FFTW_ESTIMATE )

		! prepare supporting arrays for integration
		do iy = 1, ny/2 + 1
 			karrayy(iy) = iy - 1
		end do
		do iy = ny/2 + 2, ny
			karrayy(iy) = -ny + iy - 1
		end do

		do ix = 1, nx/2 + 1
			karrayx(ix) = ix - 1
		end do

		do iy = 1, ny
			derivx(:, iy) = 2.0d0 * PI / Lx * karrayx
		end do
		do ix = 1, nx/2 + 1
			derivy(ix, :) = 2.0d0 * PI / Ly * karrayy
		end do

		do iy = 1, ny
			do ix = 1, nx/2 + 1
				! qarray contains the linear part as in regular exponential time differencing
				select case (modelid)
				case (0) ! KSE
					qarray(ix, iy) = - controlparam(1) + ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
										+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)&
							- ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
								+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)**2.0d0
				case (1) ! NE
					qarray(ix, iy) = - controlparam(1) + (controlparam(2) - 1.0d0) * ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
										+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)&
							+ 2.0d0 * ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
								+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)**2.0d0&
							- ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
							+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)**3.0d0
				case default
					qarray(ix, iy) = ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
										+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)&
							- ((2.0d0 * PI / Lx * karrayx(ix))**2.0d0 &
								+ (2.0d0 * PI / Ly * karrayy(iy))**2.0d0)**2.0d0
				end select

				a0(ix, iy) = exp( dtime * qarray(ix, iy) / 2.0d0 )
				if (abs(dtime * qarray(ix, iy)) < 0.5d0) then
					! see: Kassam, Aly-Khan, and Lloyd N. Trefethen. "Fourth-order time-stepping for stiff PDEs." SIAM Journal on Scientific Computing 26.4 1214-1233 (2005).
					a1(ix, iy) = dtime * &!
							contourInta1( dtime * qarray(ix, iy) )
					a2(ix, iy) = dtime * &!
							contourInta2( dtime * qarray(ix, iy) )
					a3(ix, iy) = dtime * &!
							contourInta3( dtime * qarray(ix, iy) )
					a4(ix, iy) = dtime * &!
							contourInta4( dtime * qarray(ix, iy) )
				else
					a1(ix, iy) = (exp(dtime * qarray(ix, iy) / 2.0d0) - 1.0d0) / qarray(ix, iy)
					a2(ix, iy) = (-4.0d0 - dtime * qarray(ix, iy) + &
						exp(dtime * qarray(ix, iy)) * (4.0d0 - 3.0d0 * dtime * qarray(ix, iy) + (dtime * qarray(ix, iy))**2.0d0)) / &
						(qarray(ix, iy)**3.0d0 * dtime**2.0d0)
					a3(ix, iy) = 2.0d0 * (2.0d0 + dtime * qarray(ix, iy) + &
						exp(dtime * qarray(ix, iy)) * (-2.0d0 + dtime * qarray(ix, iy))) / &
						(qarray(ix, iy)**3.0d0 * dtime**2.0d0)
					a4(ix, iy) = (-4.0d0 - 3.0d0 * dtime * qarray(ix, iy) - (dtime * qarray(ix, iy))**2.0d0 + &
						exp(dtime * qarray(ix, iy)) * (4.0d0 - dtime * qarray(ix, iy))) / &
						(qarray(ix, iy)**3.0d0 * dtime**2.0d0)
				end if
			end do
		end do

		! helper functions for initialization
		contains
		! evaluates contour-integral at z for coefficients a1
		real (kind = 8) function contourInta1( z )
			real (kind = 8) :: z, alpha
			complex (kind = 8) :: integral, t

			integer :: k

			! alpha = 0
			alpha = 0.0d0
			t = z + 1.0d0
			integral = (exp(t/2.0d0) - 1.0d0)/t &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			do k = 1, Ncontourintegral - 1
				alpha = k * PI / Ncontourintegral
				t = z + exp(alpha * (0.0d0, 1.0d0))
				integral = integral + &
						2.0d0 * (exp(t/2.0d0) - 1.0d0)/t &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)
			end do
			! alpha = PI
			alpha = PI
			t = z - 1.0d0
			integral = integral + (exp(t/2.0d0) - 1.0d0)/t &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			contourInta1 = real(integral/ 2.0d0 / Ncontourintegral)

		end function
		! evaluates contour-integral at z for coefficients a2
		real (kind = 8) function contourInta2( z )
			real (kind = 8) :: z, alpha
			complex (kind = 8) :: integral, t

			integer :: k

			! alpha = 0
			alpha = 0.0d0
			t = z + 1.0d0
			integral = (-4.0d0 - t + exp(t) * (4.0d0 - 3.0d0 * t + t * t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			do k = 1, Ncontourintegral - 1
				alpha = k * PI / Ncontourintegral
				t = z + exp(alpha * (0.0d0, 1.0d0))
				integral = integral + &
						2.0d0 * (-4.0d0 - t + exp(t) * (4.0d0 - 3.0d0 * t + t * t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)
			end do
			! alpha = PI
			alpha = PI
			t = z - 1.0d0
			integral = integral + (-4.0d0 - t + exp(t) * (4.0d0 - 3.0d0 * t + t * t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			contourInta2 = real(integral/ 2.0d0 / Ncontourintegral)

		end function
		! evaluates contour-integral at z for coefficients a3
		real (kind = 8) function contourInta3( z )
			real (kind = 8) :: z, alpha
			complex (kind = 8) :: integral, t

			integer :: k

			! alpha = 0
			alpha = 0.0d0
			t = z + 1.0d0
			integral = 2.0d0 * (2.0d0 + t + exp(t) * (-2.0d0 + t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			do k = 1, Ncontourintegral - 1
				alpha = k * PI / Ncontourintegral
				t = z + exp(alpha * (0.0d0, 1.0d0))
				integral = integral + &
						2.0d0 * 2.0d0 * (2.0d0 + t + exp(t) * (-2.0d0 + t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)
			end do
			! alpha = PI
			alpha = PI
			t = z - 1.0d0
			integral = integral + 2.0d0 * (2.0d0 + t + exp(t) * (-2.0d0 + t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			contourInta3 = real(integral/ 2.0d0 / Ncontourintegral)

		end function
		! evaluates contour-integral at z for coefficients a4
		real (kind = 8) function contourInta4( z )
			real (kind = 8) :: z, alpha
			complex (kind = 8) :: integral, t

			integer :: k

			! alpha = 0
			alpha = 0.0d0
			t = z + 1.0d0
			integral = (-4.0d0 - 3.0d0 * t - t * t + exp(t) * (4.0d0 - t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			do k = 1, Ncontourintegral - 1
				alpha = k * PI / Ncontourintegral
				t = z + exp(alpha * (0.0d0, 1.0d0))
				integral = integral + &
						2.0d0 * (-4.0d0 - 3.0d0 * t - t * t + exp(t) * (4.0d0 - t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)
			end do
			! alpha = PI
			alpha = PI
			t = z - 1.0d0
			integral = integral + (-4.0d0 - 3.0d0 * t - t * t + exp(t) * (4.0d0 - t))/t**3.0d0 &
						* exp(alpha * (0.0d0, 1.0d0))/ (t - z)

			contourInta4 = real(integral/ 2.0d0 / Ncontourintegral)

		end function
	end subroutine
	subroutine ETDRK4_free( )
		call fftw_free(p)
		call dfftw_destroy_plan( fftw_plan_freq_partialx )
		call dfftw_destroy_plan( fftw_plan_freq_partialy )
		call dfftw_destroy_plan( fftw_plan_rtemp )

		deallocate(real_data)
		deallocate(freq_data)
		deallocate(a0)
		deallocate(a1)
		deallocate(a2)
		deallocate(a3)
		deallocate(a4)
		deallocate(karrayx)
		deallocate(karrayy)
		deallocate(qarray)
		deallocate(derivx)
		deallocate(derivy)

		deallocate(controlparam)
	end subroutine
	! remove constant offset in current data arrays
	subroutine resetzeromode()
		freq_partialx = freq_data
		freq_partialx(1, 1) = 0.0d0
		call dfftw_execute_dft_c2r( fftw_plan_freq_partialx, freq_partialx, real_partialx)
		real_data = real_partialx
		freq_data(1, 1) = 0.0d0
	end subroutine
	! calculate the nonlinearity for the Fourier data "somefreq_data" at time "sometime"
	function getNonlinearity(somefreq_data, sometime)
		real (kind = 8) :: sometime
		complex (kind = 8), dimension(nx/2 + 1, ny) :: getNonlinearity
		complex (kind = 8), dimension(nx/2 + 1, ny), intent(in) :: somefreq_data

		select case (modelid)
		case (0) ! KSE
			freq_partialx = derivx * (0.0d0, 1.0d0) * somefreq_data
			freq_partialy = derivy * (0.0d0, 1.0d0) * somefreq_data
			call dfftw_execute_dft_c2r( fftw_plan_freq_partialx, freq_partialx, real_partialx)
			call dfftw_execute_dft_c2r( fftw_plan_freq_partialy, freq_partialy, real_partialy)
			rtemp = (real_partialx * real_partialx + real_partialy * real_partialy)
			call dfftw_execute_dft_r2c( fftw_plan_rtemp, rtemp, ctemp)
			getNonlinearity = ctemp / real(nx * ny)
		case (1) ! NE
			freq_partialx = derivx * (0.0d0, 1.0d0) * somefreq_data
			freq_partialy = derivy * (0.0d0, 1.0d0) * somefreq_data
			call dfftw_execute_dft_c2r( fftw_plan_freq_partialx, freq_partialx, real_partialx)
			call dfftw_execute_dft_c2r( fftw_plan_freq_partialy, freq_partialy, real_partialy)
			rtemp = (real_partialx * real_partialx + real_partialy * real_partialy)
			call dfftw_execute_dft_r2c( fftw_plan_rtemp, rtemp, ctemp)
			getNonlinearity = -0.5d0 * ctemp / real(nx * ny)
		case default
			getNonlinearity = 0.0d0
		end select

	end function
	! nstep: execute nstep integration steps
	! breset: reset zero-mode after each integration step if desired like for the undamped KSE
	subroutine step( nstep, breset )
		real (kind = 8) :: time0
		complex (kind = 8), dimension(nx/2 + 1, ny) :: N1, N2, N3, N4
		complex (kind = 8), dimension(nx/2 + 1, ny) :: freqtemp, freqtemp2
		integer :: nstep, istep, jstep
		logical, optional :: breset

		time0 = time
		do istep = 1, nstep
			! calculate first interstep
			N1 = getNonlinearity(freq_data, time0 + real(istep-1)*dtime)
			freqtemp = a0 * freq_data + a1 * N1
			freqtemp2 = freqtemp ! backup for later interstep

			! calc second interstep
			N2 = getNonlinearity(freqtemp, time0 + (real(istep-1) + 0.5d0)*dtime)
			freqtemp = a0 * freq_data + a1 * N2

			! calc third interstep
			N3 = getNonlinearity(freqtemp, time0 + (real(istep-1) + 0.5d0)*dtime)
			freqtemp = a0 * freqtemp2 + a1 * (2.0d0 * N3 - N1)

			! do step
			N4 = getNonlinearity(freqtemp, time0 + (real(istep-1) + 1.0d0)*dtime)
			freq_data = a0 * a0 * freq_data + a2 * N1 + a3 * (N2 + N3) + a4 * N4

			! reset zero-mode if desired like for undamped KSE
			if (present(breset)) then
				if (breset) freq_data(1, 1) = 0.0d0
			end if

			! for real-valued field equation the corresponding complex-valued Fourier-field is symmetric
			! this is not reflected by the integration scheme and has to be restored
			! resymmetrize freq_data(1, :) and freq_data(nx/2 + 1, :)
			do jstep = 1, ny/2 - 1
				freq_data(1, ny + 1 - jstep) = dconjg(freq_data(1, jstep + 1))
				freq_data(nx/2 + 1, ny + 1 - jstep) = dconjg(freq_data(nx/2 + 1, jstep + 1))
			end do
			freq_data(1, 1) = real(freq_data(1, 1))
			freq_data(nx/2 + 1, 1) = real(freq_data(nx/2 + 1, 1))
			! resymmetrize using fft (easy and less error-prone but lazy and costly)
			!freq_partialx = freq_data
			!call dfftw_execute_dft_c2r( fftw_plan_freq_partialx, freq_partialx, real_partialx)
			!rtemp = real_partialx
			!call dfftw_execute_dft_r2c( fftw_plan_rtemp, rtemp, ctemp)
			!freq_data = ctemp / real(nx * ny)
		end do
		! apply step to real field
		freq_partialx = freq_data
		call dfftw_execute_dft_c2r( fftw_plan_freq_partialx, freq_partialx, real_partialx)
		real_data = real_partialx
		time = time0 + real(nstep) * dtime

	end subroutine
	! use to read data from previous call to snapshot like "call snapshot( real_data, 0, 'backup.dat' )"
	! this requires the field to be written in a matrix format (like "snapshot" does)
	subroutine initfromfile( filename )
		integer :: i
		character(*) :: filename

		open (unit = 99, file = filename, status = 'old')

		do i = 1, ny
			read(99, *) real_data(:, i)
		end do

		freq_data = dfft(nx, ny, real_data)

		close(99)
	end subroutine
	! cinput is data in Fourier space; returns a complex array in fourier space with number of samples increased by factor
	function upscaledfield( cinput, factor )
		integer :: factor, ix, iy
		complex(kind = 8) :: upscaledfield(factor*nx/2 + 1, factor*ny), cinput(nx/2 + 1, ny)

		upscaledfield = 0.0d0
		do iy = 1, ny/2 + 1
			do ix = 1, nx/2 + 1
				upscaledfield(ix, iy) = cinput(ix, iy)
			end do
		end do
		do iy = ny, ny/2 + 2, -1
			do ix = 1, nx/2 + 1
				upscaledfield(ix, (factor - 1) * ny + iy) = cinput(ix, iy)
			end do
		end do
	end function
	! writes real data array rinput as matrix into file; can be used as initial state and loaded using initfromfile( filename )
	! ksnapshots: counter for standard output file format
	! filename0: optional parameter for output filepath
	subroutine snapshot( rinput, ksnapshots, filename0 )
		integer :: ksnapshots
		integer :: isnapshot, is
		character( len = 999 ) :: filename, dummy
		character( len = 8 ) :: out_format = '(I5.5)'
		real ( kind = 8 ) :: rinput( :, : )
		character( * ), optional :: filename0

		if (present(filename0)) then
			filename = filename0
		else
			! convert int to str
			write (dummy, out_format) ksnapshots
			! combine parts
			filename = 'data/out'//trim(dummy)//'.dat'
		end if

		open(unit = 110, file = trim(filename), status = 'replace')

		do is = 1, size(rinput(1, :))
			write(110, *) rinput(:, is)
		end do

		close(110)

	end subroutine
	! writes Fourier space data array cinput as matrix into file;
	! imode: identifier that determines the written data (real/imaginary part, absolute value, or phase)
	! ksnapshotsf: counter for standard output file format
	! filename0: optional parameter for output filepath
	subroutine snapshotf( cinput, imode, ksnapshotsf, filename0 )
		integer :: ksnapshotsf
		integer :: isnapshot, imode, is, js
		character( len = 999 ) :: filename, dummy
		character( len = 8 ) :: out_format = '(I5.5)'
		complex ( kind = 8 ) :: cinput( nx/2 + 1, ny )
		real ( kind = 8 ) :: routput( nx, ny )
		character( * ), optional :: filename0

		if (present(filename0)) then
			filename = filename0
		else
			! convert int to str
			write (dummy, out_format) ksnapshotsf
			! combine parts
			filename = 'data/out'//trim(dummy)//'.dat'
		end if

		open(unit = 110, file = trim(filename), status = 'replace')

		routput = 0.0d0

		select case( imode )
		case( 0 )
			do is = 0, nx/2 - 1
				do js = 0, ny/2
					routput(1 + is, ny/2 + js) = abs(cinput(nx/2 + 1 - is, js + 1))
					routput(nx/2 + 1 + is, ny/2 + js) = abs(cinput(is + 1, js + 1))
				end do
				do js = 1, ny/2 - 1
					routput(1 + is, js) = abs(cinput(nx/2 + 1 - is, ny/2 + js + 1))
					routput(nx/2 + 1 + is, js) = abs(cinput(is + 1, ny/2 + js + 1))
				end do
			end do
		case( 1 ) ! real
			do is = 0, nx/2 - 1
				do js = 0, ny/2
					routput(1 + is, ny/2 + js) = real(cinput(nx/2 + 1 - is, js + 1))
					routput(nx/2 + 1 + is, ny/2 + js) = real(cinput(is + 1, js + 1))
				end do
				do js = 1, ny/2 - 1
					routput(1 + is, js) = real(cinput(nx/2 + 1 - is, ny/2 + js + 1))
					routput(nx/2 + 1 + is, js) = real(cinput(is + 1, ny/2 + js + 1))
				end do
			end do
		case( 2 ) ! aimag
			do is = 0, nx/2 - 1
				do js = 0, ny/2
					routput(1 + is, ny/2 + js) = aimag(cinput(nx/2 + 1 - is, js + 1))
					routput(nx/2 + 1 + is, ny/2 + js) = aimag(cinput(is + 1, js + 1))
				end do
				do js = 1, ny/2 - 1
					routput(1 + is, js) = aimag(cinput(nx/2 + 1 - is, ny/2 + js + 1))
					routput(nx/2 + 1 + is, js) = aimag(cinput(is + 1, ny/2 + js + 1))
				end do
			end do
		case( 3 ) ! phase
			do is = 0, nx/2 - 1
				do js = 0, ny/2
					routput(1 + is, ny/2 + js) = atan2(aimag((cinput(nx/2 + 1 - is, js + 1))), &
										real((cinput(nx/2 + 1 - is, js + 1))))
					routput(nx/2 + 1 + is, ny/2 + js) = atan2(abs(cinput(is + 1, js + 1)), &
										real(cinput(is + 1, js + 1)))
				end do
				do js = 1, ny/2 - 1
					routput(1 + is, js) = atan2(aimag(cinput(nx/2 + 1 - is, ny/2 + js + 1)), &
										real(cinput(nx/2 + 1 - is, ny/2 + js + 1)))
					routput(nx/2 + 1 + is, js) = atan2(aimag(cinput(is + 1, ny/2 + js + 1)),&
										real(cinput(is + 1, ny/2 + js + 1)))
				end do
			end do
		end select
		do is = 1, ny
			write(110, *) routput(:, is)
		end do
		close(110)
	end subroutine
	! adds a perturbation to the current data arrays
	! ramplitude: amplitude for perturbation
	! rseed: optional parameter to change seed to some specific value
	subroutine perturbation(ramplitude, rseed)
		real(kind = 8) :: ramplitude
		integer :: irx, iry
		integer, optional :: rseed

		if (present(rseed)) &
			call srand(rseed)

		do irx = 1, nx
			do iry = 1, ny
				real_data(irx, iry) = real_data(irx, iry) &
							+ 2.0d0 * ramplitude * (rand() - 0.5d0)
			end do
		end do
		freq_data = dfft(nx, ny, real_data)

	end subroutine
end module


*DECK ISAMAX
      INTEGER FUNCTION ISAMAX (N, SX, INCX)
C***BEGIN PROLOGUE  ISAMAX
C***PURPOSE  Find the smallest index of that component of a vector
C            having the maximum magnitude.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A2
C***TYPE      SINGLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C   ISAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of single precision SX.
C     ISAMAX = first I, I = 1 to N, to maximize  ABS(SX(IX+(I-1)*INCX)),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   920618  Slight restructuring of code.  (RWC, WRB)
C***END PROLOGUE  ISAMAX
      REAL SX(*), SMAX, XMAG
      INTEGER I, INCX, IX, N
C***FIRST EXECUTABLE STATEMENT  ISAMAX
      ISAMAX = 0
      IF (N .LE. 0) RETURN
      ISAMAX = 1
      IF (N .EQ. 1) RETURN
C
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increment not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      SMAX = ABS(SX(IX))
      IX = IX + INCX
      DO 10 I = 2,N
        XMAG = ABS(SX(IX))
        IF (XMAG .GT. SMAX) THEN
          ISAMAX = I
          SMAX = XMAG
        ENDIF
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increments equal to 1.
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
        XMAG = ABS(SX(I))
        IF (XMAG .GT. SMAX) THEN
          ISAMAX = I
          SMAX = XMAG
        ENDIF
   30 CONTINUE
      RETURN
      END


SUBROUTINE PreparePreconditioner(PreconditioningMatrix,FineGrid,GhostGridX, GhostGridY, GhostGridZ, &
		alpha, beta, gamma, Precond, CurvilinearONOFF,fileop)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
INTEGER :: GhostGridX, GhostGridY, GhostGridZ, alpha, beta, gamma, kappa, Precond, CurvilinearONOFF, iERR
INTEGER :: Nxg,Nyg,Nzg,Nx,Ny,Nz,fileop
TYPE (Level_def)       :: FineGrid
TYPE (SparseArray_COO) :: PreconditioningMatrix
TYPE (Wavefield_FS)    :: tmp_wavefield
TYPE (Diff_def)        :: FullRankStencils
!TYPE (Diff_def) :: DiffStencils
!REAL(KIND=long), DIMENSION(:,:), ALLOCATABLE :: tmpdsigma
Nx  = FineGrid%Nx
Ny  = FineGrid%Ny
Nz  = FineGrid%Nz
Nxg = FineGrid%Nx + 2*GhostGridX
Nyg = FineGrid%Ny + 2*GhostGridY
Nzg = FineGrid%Nz + GhostGridZ
SELECT CASE (Precond)
	CASE (1) ! Linear LU-preconditining
		IF (CurvilinearONOFF==1) THEN
		    ! FDM stencils - vertical stencils needed for precond. matrix generation
	        CALL PreProcessDiffStencilsZ(FineGrid,FineGrid%DiffStencils,GhostGridZ,gamma,fileop)

			! determine curvilinear transformation weights for the 2D plane
			CALL DetermineCurvilinearTransform2D(FineGrid,alpha,beta,gamma,GhostGridX,GhostGridY,GhostGridZ)
			! determine normal vectors at boundary nodes for the 2D plane boundaries
 			CALL ComputeNormalVectors(FineGrid,GhostGridX,GhostGridY,GhostGridZ)

			! Determine linear sigma-coefficients
			ALLOCATE(FineGrid%dsigmanew(Nzg,Nxg,Nyg,5),STAT=iERR)
            CALL CheckError(iERR,11)
            FineGrid%dsigmanew = zero

	        CALL ALLOCATE_Wavefield_Type(tmp_wavefield, Nx, Ny, Nz, GhostGridX, GhostGridy, GhostGridZ, 0)

		    CALL DetermineTransformationConstantsArray(Nxg,Nyg,Nzg,FineGrid,FineGrid%dsigmanew,tmp_wavefield)
	        CALL DEALLOCATE_Wavefield_Type(tmp_wavefield, Nx, Ny, Nz, 0)

			! Construct preconditioning matrix

			! First, deallocate stencils for computational grid and instead determine these to the order of the
			kappa = alpha
			IF (alpha/=beta) THEN
				! FIXME: just picking the largest of alpha and beta here... perhaps check that they are equal in 3D
				kappa = MAX(alpha,beta)
			END IF
			CALL DetermineGenericStencils(FineGrid%CurvilinearStuff%DiffStencilsPrecond,kappa)
            !
            ! GD: Determine the cross derivatives coefficients
            CALL ConstructTableCrossDerivatives_Curvilinear(FineGrid, FineGrid%CurvilinearStuff%DiffStencilsPrecond, kappa, &
            	GhostGridX, GhostGridY, GhostGridZ)
    		!CALL ConstructTableCrossDerivatives_Curvilinear(FineGrid, FineGrid%CurvilinearStuff%DiffStencils, kappa, &
            !	GhostGridX, GhostGridY, GhostGridZ)
			! now we have both transformation weights, geometic information (normal vectors) and stencils...
			! let's construct a linear preconditioning matrix using this information

			CALL BuildLinearSystemTransformedMatrixCurvilinear(FineGrid, kappa, GhostGridX, GhostGridY, GhostGridZ)
			DEALLOCATE(FineGrid%DiffStencils%StencilZ)
            ! GD: deallocate the cross derivative matrices...
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesX_XZorXY)
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesY_YZorXY)
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%IndexesZ_XZorYZ)
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsX_XZorXY)
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsY_YZorXY)
            DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencilsPrecond%StencilsZ_XZorYZ)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%IndexesX_XZorXY)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%IndexesY_YZorXY)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%IndexesZ_XZorYZ)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%StencilsX_XZorXY)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%StencilsY_YZorXY)
!$$$$$$             DEALLOCATE(FineGrid%CurvilinearStuff%DiffStencils%StencilsZ_XZorYZ)

		ELSE
			ALLOCATE( FineGrid%dsigmanew(Nzg,Nxg,Nyg,5),STAT=iERR )
            CALL CheckError(iERR,10)

		    CALL PreProcessDiffStencils(FineGrid,FineGrid%DiffStencils,GhostGridX,GhostGridY,GhostGridZ, alpha,beta,gamma,fileop)
!            print*,'alpha=',alpha
!            print*,'beta=',beta
!            print*,'gamma=',gamma
!            print*,'Nxg=',Nxg
!            print*,'Nyg=',Nyg
!            print*,'Nzg=',Nzg
!            read*
			CALL PrepareFullOperatorStencils(FineGrid%DiffStencils,FullRankStencils,alpha,beta,gamma,Nxg,Nyg,Nzg) ! table for generating linear system
                    CALL ALLOCATE_Wavefield_Type(tmp_wavefield, Nx, Ny, Nz, GhostGridX, GhostGridy, GhostGridZ, 0)

		    CALL DetermineTransformationConstantsArray(Nxg,Nyg,Nzg,FineGrid,FineGrid%dsigmanew,tmp_wavefield)
            ! GD: Determine the cross derivatives coefficients
            CALL ConstructTableCrossDerivatives(FineGrid, FineGrid%DiffStencils, gamma, GhostGridX, GhostGridY, GhostGridZ, 1)
            !
		    CALL BuildLinearSystemMatrix(Nxg,Nyg,Nzg,PreconditioningMatrix,GhostGridX, GhostGridY, GhostGridZ,&
			     FineGrid%dsigmanew,FineGrid,FullRankStencils,alpha,beta,gamma)
			CALL DEALLOCATE_Wavefield_Type(tmp_wavefield, Nx, Ny, Nz, 0)
            ! GD: deallocate the cross derivative matrices...
            DEALLOCATE(FineGrid%DiffStencils%IndexesX_XZorXY)
            DEALLOCATE(FineGrid%DiffStencils%IndexesY_YZorXY)
            DEALLOCATE(FineGrid%DiffStencils%IndexesZ_XZorYZ)
            DEALLOCATE(FineGrid%DiffStencils%StencilsX_XZorXY)
            DEALLOCATE(FineGrid%DiffStencils%StencilsY_YZorXY)
            DEALLOCATE(FineGrid%DiffStencils%StencilsZ_XZorYZ)
			! Deallocate the full rank stencils
			DEALLOCATE(FineGrid%DiffStencils%FullRankIndexXZ)
			DEALLOCATE(FineGrid%DiffStencils%FullRankIndexYZ)
			DEALLOCATE(FineGrid%DiffStencils%FullRankStencilXZ)
			DEALLOCATE(FineGrid%DiffStencils%FullRankStencilYZ)
		ENDIF
		CALL CleanSparseMatrixCOO(FineGrid%PreconditioningMatrix)
!	filename = "SparseMatrix.bin"
!CALL StoreSparseMatrix(FineGrid%PreconditioningMatrix,filename)
!	filename = "dsigma.bin"
!CALL StoreRealArray(FineGrid%dsigma,(FineGrid%Nx+2*GhostGridX)*(FineGrid%Ny+2*GhostGridY)*(FineGrid%Nz+GhostGridZ),5,filename)
		PRINT*,'  Preconditioning matrix generated.'
		WRITE(FILEOP,*)'  Preconditioning matrix generated.'
	CASE (3) ! Multigrid
	CASE DEFAULT
		PRINT *,'Error: No default precondtioning strategy. (PreparePreconditioner)'
		STOP
END SELECT
END SUBROUTINE PreparePreconditioner


      subroutine rbstreg(x,y,r,nd,np,nch,b,bsv,work,cov,xxinv,iter_max,
     &    icvg,nomit)

ccc    general complex robust multiple regression; uses qr
ccc    ==> nd,np,nch = length of data vectors, # of predictors, # of data channels to fit
ccc    ==> x(nd,np) = complex predictor variables
ccc    ==> y(nd,nch) = complex data to fit (currently: regressed one at a time)
ccc    ==> nomit = number of data points omitted by multiplying by zero
ccc    <== r(nd,nch) = complex residuals
ccc    <== b(np,nch) = complex regression parameters
ccc    <== cov(*) = covariance estimates for noise in predicted channels

      integer nd,np,nch,ldx,lwork,iw1,iw2,info,icvg
      complex x(nd,np),y(nd,nch),r(nd,nch),b(np,nch),
     &   bsv(np,nch)
      character*1 side,trans,diag,uplo
      complex cov(*),cdotc,xxinv(np,np)
      logical ldone
      real work(*)

      parameter (r0 = 1.4, tol=.001)

ccc       cfac is "correction factor" for Huber style sd estimate
ccc          Huber penalty, complex data ....
      cfac = 1./(2*(1.-(1.+r0)*exp(-r0) ))

ccc   compute complex q-r decompostion : using LAPACK
      nt = nd*nch
      nt2 = 2*nt
      np2 = 2*np
      nd2 = 2*nd
      ldx = nd
      lwork = 100*np
ccc       work(1:np) = scalar factors of elementary reflectors (save)
ccc       work(np+1:np+lwork)
      iw1 = 1
      iw2 = 2*np+1
      iw3 = iw2 + 2*lwork
      call cgeqrf(nd,np,x,ldx,work(iw1),work(iw2),lwork,info)
c      write(*,*) 'info, optimal block size',info,work(iw2)

      do iter = 0,iter_max
ccc      put "corrected" data into array r
         call datawt(iter,nd,nch,y,r,r,work(iw3),r0)

ccc      compute Q^Y (uses full unitary matrix Q, data vectors (Y)
ccc             are stored in R)
         side = 'L'
         trans = 'C'
         ldr = ldx
         call cunmqr(side,trans,nd,nch,np,x,ldx,work(iw1),r,ldr
     &    ,work(iw2),lwork,info)

ccc     save old estimates, move Q^Y into b
ccc     blank upper part of Q^Y (leaving rotated residuals)
         do i = 1,nch
            do j = 1,np
               bsv(j,i) = b(j,i)
               b(j,i) = r(j,i)
               r(j,i) = (0.,0.)
            enddo
         enddo

ccc      compute residuals for corrected data
         side = 'L'
         trans = 'N'
         call cunmqr(side,trans,nd,nch,np,x,ldx,work(iw1),r,ldr
     &       ,work(iw2),lwork,info)

ccc      calculate error covariance
         ij = 0
         ndf = max(1,nd-nomit-np)
         do i = 1,nch
            do j = 1,i
               ij = ij + 1
               if(iter.gt.0) then
                  cov(ij) = cfac*cdotc(nd,r(1,j),1,r(1,i),1)/ndf
               else
                  cov(ij) = cdotc(nd,r(1,j),1,r(1,i),1)/ndf
               endif
            enddo
         enddo

ccc      move Q^Y back into R; zero out bottom part for computation
ccc      of predicted data
         do i = 1,nch
            do j = 1,np
               r(j,i) = b(j,i)
            enddo
            do j = np+1,nd
               r(j,i) = (0.,0.)
             enddo
          enddo

ccc      now compute predicted data (uses full unitary matrix Q)
         side = 'L'
         trans = 'N'
         call cunmqr(side,trans,nd,nch,np,x,ldx,work(iw1),r,ldr
     &       ,work(iw2),lwork,info)

ccc      compute new estimates B
         trans = 'N'
         diag = 'N'
         uplo = 'U'
         call ctrtrs(uplo,trans,diag,np,nch,x,ldx,b,np,info)

ccc      check to see if iterative scheme has converged
         if(iter.gt.0) then
            chngmx = 0.0
            ldone = .true.
            do i = 1,nch
               chng = snrm2(np2,bsv(1,i),1)
               do j = 1,np
                  bsv(j,i) = b(j,i)-bsv(j,i)
               enddo
               chng = snrm2(np2,bsv(1,i),1)/chng
               chngmx = max(chng,chngmx)
               ldone = ldone .and. ( chng.le.tol )
            enddo
         else if(iter_max.eq.0) then
            ldone = .true.
         else
            ldone = .false.
         endif

         if(ldone) then
            icvg = iter
ccc         compute XXinv
            do i = 1,np
               do j = 1,np
                  if(i.eq.j) then
                     xxinv(i,j) = (1.,0.)
                  else
                     xxinv(i,j) = (0.,0.)
                  endif
               enddo
            enddo
            trans = 'C'
            diag = 'N'
            uplo = 'U'
            call ctrtrs(uplo,trans,diag,np,np,x,ldx,xxinv,np,info)
            trans = 'N'
            diag = 'N'
            uplo = 'U'
            call ctrtrs(uplo,trans,diag,np,np,x,ldx,xxinv,np,info)
            return
         else
            do i = 1,nch
               ii = (i*(i+1))/2
               iw = iw3+i-1
               work(iw) = real(cov(ii))
            enddo
         endif
      enddo ! iter

ccc   if you get here, the iterative minimization didn't converge
      icvg = - nint(chngmx/tol)
      return
      end
c__________________________________________________________________
      subroutine datawt(iter,nd,nch,y,r,c,var,r0)

ccc   given data (y) and predicted (r), compute modified data and return in c
ccc    (c can overwrite r)
      integer iter,nd,nch
      complex y(nd,nch),r(nd,nch),c(nd,nch)
      real r0,var(nch)

      if(iter.eq.0) then
ccc       just copy data into r
         nt = nd*nch
         call ccopy(nt,y,1,c,1)
      else if(iter.gt.0) then
ccc     iterative minimization of Huber penalty functional
         do i = 1,nch
            r0s = sqrt(var(i))*r0
            do j = 1,nd
               if(abs(y(j,i)-r(j,i)).gt.r0s) then
                  w = r0s/abs(y(j,i)-r(j,i))
                  c(j,i) = w*y(j,i) + (1.-w)*r(j,i)
               else
                  c(j,i) = y(j,i)
               endif
            enddo
         enddo
      endif
      return
      end