!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BenchIT - Performance Measurement for Scientific Applications
! Contact: developer@benchit.org
!
! $Id: 2dPoisson.f90 1 2009-09-11 12:26:19Z william $
! $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/applications/MGV/F95/0/0/recursive/2dPoisson.f90 $
! For license details see COPYING in the package base directory
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Kernel: multigrid methode for 2D Poisson equation
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!************ modules ************

! raus weil fortran 95 std not support allocateable subroutine arguments
!module memory
!   implicit none
!
!   ! overloading the subroutine alloc for input vector or matrix
!   interface alloc
!      module procedure alloc_vector
!      module procedure alloc_matrix
!   end interface
!
!   ! overloading the subroutine dealloc for input vector or matrix
!   interface dealloc
!      module procedure dealloc_vector
!      module procedure dealloc_matrix
!   end interface
!
!   contains
!
!   ! allocate a vector with n elements
!   subroutine alloc_vector( vector, n, str )
!      ! in/out
!      !REAL(kind=8), dimension(:), allocatable :: vector
!      REAL(kind=8), dimension(:), allocatable, intent(inout) :: vector
!      INTEGER(kind=4) :: n
!      CHARACTER(len=*) :: str
!      ! additional
!      INTEGER(kind=4) :: st
!
!      allocate( vector(1:n), stat=st )
!      if( st/=0 ) write(*,fmt='(A,A,A,I0,A)') "Error: Allocation of the vector ", str, ", status=", st, "!"
!      vector = 0
!   end subroutine alloc_vector
!
!   ! allocate a matrix with m*n elements
!   subroutine alloc_matrix( matrix, m, n, str )
!      ! in/out
!      REAL(kind=8), dimension(:,:), allocatable :: matrix
!      INTEGER(kind=4) :: m, n
!      CHARACTER(len=*) :: str
!      ! additional
!      INTEGER(kind=4) :: st
!
!      allocate( matrix(1:m,1:n), stat=st )
!      if( st/=0 ) write(*,fmt='(A,A,A,I0,A)') "Error: Allocation of the matrix ", str, ", status=", st, "!"
!      matrix = 0
!   end subroutine alloc_matrix
!
!   ! deallocate a vector
!   subroutine dealloc_vector( vector, str )
!      ! in/out
!      REAL(kind=8), dimension(:), allocatable :: vector
!      CHARACTER(len=*) :: str
!      ! additional
!      INTEGER(kind=4) :: st
!
!      deallocate( vector, stat=st )
!      if( st/=0 ) write(*,fmt='(A,A,A,I0,A)') "Error: Deallocation of the vector ", str, ", status=", st, "!"
!   end subroutine dealloc_vector
!
!   ! deallocate a matrix
!   subroutine dealloc_matrix( matrix, str )
!      ! in/out
!      REAL(kind=8), dimension(:,:), allocatable :: matrix
!      CHARACTER(len=*) :: str
!      ! additional
!      INTEGER(kind=4) :: st
!
!      deallocate( matrix, stat=st )
!      if( st/=0 ) write(*,fmt='(A,A,A,I0,A)') "Error: Dellocation of the matrix ", str, ", status=", st, "!"
!   end subroutine dealloc_matrix
!end module memory

module debug
   implicit none

   LOGICAL, parameter :: INFO=.FALSE., INFOTIME=.FALSE.     ! is used for debug output
   INTEGER(kind=4) :: st

   interface
      subroutine f90fflush()
      end subroutine f90fflush
   end interface

end module debug

!************ modules ************

!************ main programm routines ************

module my2dPoisson
   !use memory
   use debug

   implicit none

   type matrixStruct
      REAL(kind=8), dimension(:, :), allocatable :: matrix
   end type matrixStruct

   contains

   subroutine my2dPoisson_without_sparse( level0, maxlevel0, outputform, v1, v2, &
                                          & w, L1, L2, time_for_MGV, omega, flop )
      ! in/out
      INTEGER(kind=4) :: level0, maxlevel0, outputform, v1, v2
      REAL(kind=8) :: w, L1, L2
      REAL(kind=8) :: time_for_MGV, omega, flop
      ! additional
      INTEGER(kind=4) :: iter, start, counter, i, M1M1, z3, z4
      REAL(kind=8) :: res, res2, old_res
      REAL(kind=8) :: t1, t2
      CHARACTER(len=30) :: str

      type(matrixStruct), dimension(:), allocatable :: struct

      REAL(kind=8), dimension(:), allocatable :: b, solution, r, x0

      if( INFO .OR. INFOTIME ) then
         write(*,*) "my2dPoisson_without_sparse( level0, maxlevel0, outputform, &
                    & v1, v2, w, L1, L2, time_for_MGV, omega, flop ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      allocate( struct(1:level0), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the struct, status=", st, "!"
         call f90fflush()
         stop
      end if

      ! create the matrix for each level with a size constrained on the level
      do i=1, level0, 1
         M1M1 = (2**i + 1)**2
         write(str,fmt='(A,I0,A)') "struct(", i, ")%matrix"
         !CALL alloc( struct(i)%matrix, M1M1, M1M1, trim(str) )
         allocate( struct(i)%matrix(1:M1M1,1:M1M1), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,A,A,I0,A)') "Error: Allocation of matrix ", str,", status=", st, "!"
            call f90fflush()
            stop
         end if
         struct(i)%matrix = 0
      end do

      CALL initializeMatrixStruct( struct, level0 )

      if( INFO ) CALL printMatrixStruct( struct )

      !CALL alloc( b, N1N1, "b" )
      allocate( b(1:(2**level0+1)**2), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector b, status=", st, "!"
         call f90fflush()
         stop
      end if
      b = 0

      CALL initializeVectorB( b, level0, L1, L2 )
      if( INFO ) write(*,*) b

      counter = 0
      res = 0.0
      res2 = 0.0
      old_res = 1.0

      !CALL alloc( solution, (2**level0+1)**2, "solution" )
      allocate( solution(1:(2**level0+1)**2), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector solution, status=", st, "!"
         call f90fflush()
         stop
      end if
      solution = 0

      !CALL alloc( x0, (2**level0+1)**2, "x0" )
      allocate( x0(1:(2**level0+1)**2), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector x0, status=", st, "!"
         call f90fflush()
         stop
      end if
      x0 = 0

      !CALL alloc( r, (2**level0+1)**2, "r" )
      allocate( r(1:(2**level0+1)**2), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector r, status=", st, "!"
         call f90fflush()
         stop
      end if
      r = 0

      CALL bi_gettime( t1 )
      do
         CALL MGV( solution, struct, x0, b, level0, v1, v2, w )

         !r = b - struct(iter)%matrix * solution
         CALL MatVecMult( r, struct(level0)%matrix, solution )
         r = b - r

         res = maxval(abs(r))
         counter = counter + 1
         res2 = res2 + res / old_res
         old_res = res

         if( res<0.05 ) then
            exit
         else
            x0 = solution
         end if
      end do
      CALL bi_gettime( t2 )

      !CALL dealloc( r, "r" )
      deallocate( r, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector r, status=", st, "!"
         call f90fflush()
      end if

      !CALL dealloc( x0, "x0" )
      deallocate( x0, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector x0, status=", st, "!"
         call f90fflush()
      end if

      !CALL dealloc( b, "b" )
      deallocate( b, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector b, status=", st, "!"
         call f90fflush()
      end if

      if( outputform/=0 .AND. level0==maxlevel0 ) then
         !write(*,*) level0, maxlevel0
         CALL writeOutput( outputform, level0, solution, L1, L2 )
      end if

      time_for_MGV = t2-t1
      omega = res2 / counter
      flop = calcFlop(level0, counter, v1, v2)

      !CALL dealloc( solution, "solution" )
      deallocate( solution, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector solution, status=", st, "!"
         call f90fflush()
      end if

      !CALL removeMatrixStruct( struct )
      do i=1, level0, 1
         deallocate(struct(i)%matrix, stat=st)
         if( st/=0 ) then
            write(*,fmt='(A,I0,A,I0,A)') "Error: Deallocation of the matrix for level=", i, &
                                         & " not possible, status=", st, "!"
            call f90fflush()
         end if
      end do

      deallocate(struct, stat=st)
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the struct not possible, status=", st, "!"
         call f90fflush()
      end if

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "my2dPoisson_without_sparse( level0, maxlevel0, outputform, v1, v2, &
                    & w, L1, L2, time_for_MGV, omega, flop ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine my2dPoisson_without_sparse

   ! initialize for each level a matrix and safe in the struct
   ! boundary condition are also included
   subroutine initializeMatrixStruct( struct, level0 )
      ! in/out
      type(matrixStruct), dimension(:) :: struct
      INTEGER(kind=4) :: level0
      ! additional
      INTEGER(kind=4) :: i, j, M1, M1M1, column, temp, z3, z4
      REAL(kind=8) :: factor

      if( INFO .OR. INFOTIME ) then
         write(*,*) "initializeMatrixStruct( struct ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      ! fill the matrix with the diagonals scaled -1, 4, -1
      do i=1, level0, 1
         M1M1 = (2**i + 1)**2
         factor = ((2**i)**2)
         struct(i)%matrix(1:2,1) = factor * (/ 4.0, -1.0 /)
         do column=2, M1M1-1, 1
            struct(i)%matrix(column-1:column+1,column) = factor * (/ -1.0, 4.0, -1.0 /)
         end do
         struct(i)%matrix(M1M1-1:M1M1,M1M1) = factor * (/ -1.0, 4.0 /)
      end do

      ! generate the additional information for a 5-point-star for all matries and add the boundary condition
      do i=1, level0, 1
         ! 5-point-star
         !struct(i)%matrix = ((2**i)**2) * struct(i)%matrix

         M1 = 2**i+1
         M1M1 = M1**2
         ! temp = -1/h2
         temp = -((2**i)**2)
         do j=M1+1, M1M1-M1
            struct(i)%matrix(j,(/ j-M1, j+M1 /)) = (/ temp, temp /)
         end do

         ! boundary condition
         struct(i)%matrix(1,(/ 1, 2, 1+M1/)) = 0
         struct(i)%matrix(1,1) = 1
         do j=2, M1, 1
            struct(i)%matrix(j,(/ j-1, j, j+1, j+M1 /)) = 0
            struct(i)%matrix(j,j) = 1
         end do
         do j=M1M1-(M1-1), M1M1-1, 1
            struct(i)%matrix(j,(/ j-M1, j-1, j, j+1 /)) = 0
            struct(i)%matrix(j,j) = 1
         end do
         struct(i)%matrix(M1M1,(/ M1M1-M1, M1M1-1, M1M1 /)) = 0
         struct(i)%matrix(M1M1,M1M1) = 1
         do j=M1+1, M1M1-M1, M1
            struct(i)%matrix(j,(/ j-M1, j-1, j, j+1, j+M1 /)) = 0
            struct(i)%matrix(j,j) = 1
         end do
         do j=M1+M1, M1M1-M1, M1
            struct(i)%matrix(j,(/ j-M1, j-1, j, j+1, j+M1 /)) = 0
            struct(i)%matrix(j,j) = 1
         end do
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "initializeMatrixStruct( struct ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine initializeMatrixStruct

   subroutine initializeVectorB( b, level, L1, L2 )
      ! in/out
      REAL(kind=8), dimension(:) :: b
      INTEGER(kind=4) :: level
      REAL(kind=8) :: L1, L2
      ! additional
      INTEGER(kind=4) :: i, j, N1, N1N1, z3, z4
      LOGICAL :: test=.FALSE.
      REAL(kind=8), dimension(:), allocatable :: x1, x2

      if( INFO .OR. INFOTIME ) then
         write(*,*) "initializeVectorB( b, level, L1, L2 ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      !if( allocated(b) ) CALL dealloc( b, "b" )

      N1 = 2**level + 1
      N1N1 = N1**2
      !CALL alloc( b, N1N1, "b" )

      if( test ) then
         !b((j-1)*((N1-1)+1)+i) = 2
         b = 2
      else
         !CALL alloc( x1, N1, "x1 in initB" )
         allocate( x1(1:N1), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector x1 in initializeVectorB, status=", st, "!"
            call f90fflush()
            stop
         end if
         x1 = 0

         !CALL alloc( x2, N1, "x2 in initB" )
         allocate( x2(1:N1), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector x2 in initializeVectorB, status=", st, "!"
            call f90fflush()
            stop
         end if
         x2 = 0

         CALL get_x1( x1, N1, L1)
         CALL get_x2( x2, N1, L2)

         do j=1, N1, 1
             do i=1, N1, 1
               !b((j-1)*((N1-1)+1)+i) = 2 * ( x1(i)*(1-(x1(i))) + x2(j)*(1-(x2(j))) )
               b((j-1)*N1+i) = 2 * ( x1(i)*(1-(x1(i))) + x2(j)*(1-(x2(j))) )
             end do
         end do

         !CALL dealloc( x1, "x1 in initB" )
         deallocate( x1, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector x1 in initializeVectorB, status=", st, "!"
            call f90fflush()
         end if

         !CALL dealloc( x2, "x2 in initB" )
         deallocate( x2, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector x2 in initializeVectorB, status=", st, "!"
            call f90fflush()
         end if
      end if

      b(1:N1) = 0
      b(N1N1-(N1-1):N1N1) = 0
      b(N1+1:N1N1:N1) = 0
      b(N1:N1N1:N1) = 0

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "initializeVectorB( b, level, L1, L2 ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine initializeVectorB

   subroutine get_x1( x1, N1, L1 )
      ! in/out
      REAL(kind=8), dimension(:) :: x1
      INTEGER(kind=4) :: N1
      REAL(kind=8) :: L1
      ! additional
      INTEGER(kind=4) :: i, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "get_x1( x1, N1, L1 ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      do i=1, N1, 1
         x1(i) = ((i-1) * L1) / (N1-1)
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "get_x1( x1, N1, L1 ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine get_x1

   subroutine get_x2( x2, N1, L2 )
      ! in/out
      REAL(kind=8), dimension(:) :: x2
      INTEGER(kind=4) :: N1
      REAL(kind=8) :: L2
      ! additional
      INTEGER(kind=4) :: i, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "get_x2( x2, N1, L2 ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      do i=1, N1, 1
         x2(i) = ((i-1) * L2) / (N1-1)
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "get_x2( x2, N1, L2 ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine get_x2

   recursive subroutine MGV( x, struct, x0, b, level, v1, v2, w )
      ! in/out
      REAL(kind=8), dimension(:) :: x
      type(matrixStruct), dimension(:) :: struct
      REAL(kind=8), dimension(:) :: x0, b
      INTEGER(kind=4) :: level, v1, v2
      REAL(kind=8) :: w
      ! additional
      INTEGER(kind=4) :: row, n, n1, n1n1, tsize, z3, z4
      REAL(kind=8), dimension(:), allocatable :: null_vector, r, temp_vector, dx
      REAL(kind=8), dimension(:,:), allocatable :: temp_matrix1, temp_matrix2, inverse

      if( INFO .OR. INFOTIME ) then
         write(*,*) "MGV( solution, struct, x0, b, iter ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      if( level==1 ) then
         n = (2**level+1)**2
         !CALL alloc( inverse, n, n, "inverse" )
         allocate( inverse(1:n,1:n), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of matrix inverse, status=", st, "!"
            call f90fflush()
            stop
         end if
         inverse = 0

         inverse = RESHAPE( (/ 1, 0, 0, 0, 0, 0, 0, 0, 0, &
                             & 0, 1, 0, 0, 1, 0, 0, 0, 0, &
                             & 0, 0, 1, 0, 0, 0, 0, 0, 0, &
                             & 0, 0, 0, 1, 1, 0, 0, 0, 0, &
                             & 0, 0, 0, 0, 1, 0, 0, 0, 0, &
                             & 0, 0, 0, 0, 1, 1, 0, 0, 0, &
                             & 0, 0, 0, 0, 0, 0, 1, 0, 0, &
                             & 0, 0, 0, 0, 1, 0, 0, 1, 0, &
                             & 0, 0, 0, 0, 0, 0, 0, 0, 1 /), (/9,9/) )
          inverse(5,2) = inverse(5,2)/4
          inverse(5,4) = inverse(5,4)/4
          inverse(5,5) = inverse(5,5)/16
          inverse(5,6) = inverse(5,6)/4
          inverse(5,8) = inverse(5,8)/4

         ! x = inverse * b
         CALL MatVecMult( x, inverse, b )

         !CALL dealloc( inverse, "inverse" )
         deallocate( inverse, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix inverse, status=", st, "!"
            call f90fflush()
         end if
      else
         CALL JacobiRelax( x, struct(level)%matrix, x0, b, v1, w )

         !r = b - struct(level)%matrix * x
         !CALL alloc( r, size(x), "r in MGV" )
         allocate( r(1:size(x)), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector r in MGV, status=", st, "!"
            call f90fflush()
            stop
         end if
         r = 0

         CALL MatVecMult( r, struct(level)%matrix, x )
         r = b - r

         tsize = int(sqrt(real(size(r))))
         allocate( temp_matrix1(1:tsize,1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of matrix temp_matrix1 for transform_vector_to_matrix, &
                                    & status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_matrix1 = 0
         CALL transform_vector_to_matrix( temp_matrix1, r )
         deallocate( r, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector r after transform_vector_to_matrix, &
                                    & status=", st, "!"
            call f90fflush()
         end if

         tsize = 2**(level-1) + 1
         allocate( temp_matrix2(1:tsize,1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of matrix temp_matrix2 for restriction, status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_matrix2 = 0
         CALL restriction( temp_matrix2, temp_matrix1, level )
         deallocate( temp_matrix1, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix temp_matrix1 after restriction, status=", st, "!"
            call f90fflush()
         end if

         tsize = size(temp_matrix2)
         allocate( temp_vector(1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector temp_vector for transform_matrix_to_vector, &
                                    & status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_vector = 0
         CALL transform_matrix_to_vector( temp_vector, temp_matrix2 )
         deallocate( temp_matrix2, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix temp_matrix2 after transform_matrix_to_vector, &
                                    & status=", st, "!"
            call f90fflush()
         end if

         n1 = 2**(level-1) + 1
         n1n1 = n1 * n1
         temp_vector(1:n1) = 0
         temp_vector(n1n1-(n1-1):n1n1) = 0
         temp_vector(n1+1:n1n1:n1) = 0
         temp_vector(n1:n1n1:n1) = 0

         !CALL alloc( dx, n1n1, "dx in MGV" )
         allocate( dx(1:n1n1), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector dx in MGV, status=", st, "!"
            call f90fflush()
            stop
         end if
         dx = 0

         !CALL alloc( null_vector, n1n1, "null_vector in MGV" )
         allocate( null_vector(1:n1n1), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector null_vector in MGV, status=", st, "!"
            call f90fflush()
            stop
         end if
         null_vector = 0

         CALL MGV( dx, struct, null_vector, temp_vector, level-1, v1, v2, w )

         !CALL dealloc( temp_vector, "temp_vector in MGV" )
         deallocate( temp_vector, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector temp_vector in MGV, status=", st, "!"
            call f90fflush()
         end if

         tsize = int(sqrt(real(size(dx))))
         allocate( temp_matrix1(1:tsize,1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of matrix temp_matrix1 for transform_vector_to_matrix, &
                                    & status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_matrix1 = 0
         CALL transform_vector_to_matrix( temp_matrix1, dx )
         deallocate( dx, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector dx after transform_vector_to_matrix, &
                                    & status=", st, "!"
            call f90fflush()
         end if

         tsize = 2**level + 1
         allocate( temp_matrix2(1:tsize,1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of matrix temp_matrix2 for prolongation, status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_matrix2 = 0
         CALL prolongation( temp_matrix2, temp_matrix1, level )
         deallocate( temp_matrix1, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix temp_matrix1 after prolongation, status=", st, "!"
            call f90fflush()
         end if

         tsize = size(temp_matrix2)
         allocate( temp_vector(1:tsize), stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Allocation of the vector temp_vector for transform_matrix_to_vector, &
                                    & status=", st, "!"
            call f90fflush()
            stop
         end if
         temp_vector = 0
         CALL transform_matrix_to_vector( temp_vector, temp_matrix2 )
         deallocate( temp_matrix2, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix temp_matrix2 after transform_matrix_to_vector, &
                                    & status=", st, "!"
            call f90fflush()
         end if

         !CALL dealloc( null_vector, "null_vector in MGV" )
         deallocate( null_vector, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector null_vector in MGV, status=", st, "!"
            call f90fflush()
         end if

         x = x + temp_vector
         !CALL dealloc( temp_vector, "temp_vector in MGV" )
         deallocate( temp_vector, stat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector temp_vector in MGV, status=", st, "!"
            call f90fflush()
         end if

         CALL JacobiRelax( x, struct(level)%matrix, x, b, v2, w )
      end if

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "MGV( solution, struct, x0, b, iter ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine MGV

   subroutine JacobiRelax( xk_1, Ah, xk, b, v, w )
      ! in/out
      REAL(kind=8), dimension(:) :: xk_1
      REAL(kind=8), dimension(:,:) :: Ah
      REAL(kind=8), dimension(:) :: xk, b
      INTEGER(kind=4) :: v
      REAL(kind=8) :: w
      ! additional
      REAL(kind=8), dimension(:,:), allocatable :: D_inverse
      REAL(kind=8), dimension(:), allocatable :: temp_vector1, temp_vector2
      INTEGER(kind=4) :: i, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "JacobiRelax( xk_1, Ah, xk, b, v, w ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      !CALL alloc( D_inverse, size(Ah(:,1)), size(Ah(1,:)), "D_inverse" )
      allocate( D_inverse(1:size(Ah(:,1)),1:size(Ah(1,:))), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of matrix D_inverse in JacobiRelax, status=", st, "!"
         call f90fflush()
         stop
      end if
      D_inverse = 0

      !CALL alloc( temp_vector1, size(Ah(:,1)), "temp_vector" )
      allocate( temp_vector1(1:size(Ah(:,1))), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector temp_vector1 in JacobiRelax, status=", st, "!"
         call f90fflush()
         stop
      end if
      temp_vector1 = 0

      !CALL alloc( temp_vector2, size(Ah(:,1)), "temp_vector2" )
      allocate( temp_vector2(1:size(Ah(:,1))), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector temp_vector2 in JacobiRelax, status=", st, "!"
         call f90fflush()
         stop
      end if
      temp_vector2 = 0

      do i=1, size(Ah(:,1)), 1
         D_inverse(i,i) = 1.0 / Ah(i,i)
      end do

      do i=1, v, 1
         !xk_1 = xk - w * D_inverse * ( Ah * xk - b )
         CALL MatVecMult( temp_vector1, Ah, xk )
         temp_vector1 = temp_vector1 - b
         CALL MatVecMult( temp_vector2, D_inverse, temp_vector1 )
         xk_1 = xk - w * temp_vector2
         xk = xk_1
      end do

      !CALL dealloc( D_inverse, "D_inverse" )
      deallocate( D_inverse, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of matrix D_inverse in JacobiRelax, status=", st, "!"
         call f90fflush()
      end if

      !CALL dealloc( temp_vector1, "temp_vector" )
      deallocate( temp_vector1, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector temp_vector1 in JacobiRelax, status=", st, "!"
         call f90fflush()
      end if

      !CALL dealloc( temp_vector2, "temp_vector2" )
      deallocate( temp_vector2, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector temp_vector2 in JacobiRelax, status=", st, "!"
         call f90fflush()
      end if

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "JacobiRelax( xk_1, Ah, xk, b, v, w ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine JacobiRelax

   subroutine transform_vector_to_matrix( matrix, vector )
      ! in/out
      REAL(kind=8), dimension(:,:) :: matrix
      REAL(kind=8), dimension(:) :: vector
      ! additional
      INTEGER(kind=4) :: i, n, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "transform_vector_to_matrix( matrix, vector ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      n = int(sqrt(real(size(vector))))

      !CALL alloc( matrix, n, n, "for transform vec2mat" )

      !matrix = reshape( vector, (/ n, n /))
      do i=1, n, 1
          matrix(n-i+1,:) = vector((i-1)*n+1:(i-1)*n+n)
      end do

      !CALL dealloc( vector, "for transform vec2mat" )

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "transform_vector_to_matrix( matrix, vector ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine transform_vector_to_matrix

   subroutine transform_matrix_to_vector( vector, matrix )
      ! in/out
      REAL(kind=8), dimension(:) :: vector
      REAL(kind=8), dimension(:,:) :: matrix
      ! additional
      INTEGER(kind=4) :: i, n, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "transform_matrix_to_vector( vector, matrix ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      !CALL alloc( vector, size(matrix), "for transform mat2vec" )

      n = size(matrix(:,1))

      !vector = reshape( matrix, (/ n /))
      do i=1, n, 1
          vector((i-1)*n+1:(i-1)*n+n) = matrix(n-i+1,:)
      end do

      !CALL dealloc( matrix, "for transform mat2vec" )

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "transform_matrix_to_vector( vector, matrix ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine transform_matrix_to_vector

   subroutine restriction( u, r0, level )
      ! in/out
      REAL(kind=8), dimension(:,:) :: u, r0         ! u=outMatrix, r0=inMatrix
      INTEGER(kind=4) :: level
      ! additional
      REAL(kind=8), dimension(:,:), allocatable :: r   ! r=blowUpMatrix
      INTEGER(kind=4) :: i, j, n, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "restriction( u, r0, level ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      n = size(r0(:,1))+2
      allocate( r(1:n,1:n), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of vector r in restriction, status=", st, "!"
         call f90fflush()
         stop
      end if

      r(:,1) = 0
      r(:,n) = 0
      r(1,:) = 0
      r(n,:) = 0

      r(2:2**level+2, 2:2**level+2) = r0

      n = 2**(level-1) + 1

      !CALL dealloc( r0, "r0" )
      !CALL alloc( u, n, n, "u in restric" )

      do j=1, n, 1
         do i=1, n, 1
            u(i,j) = 1.0/4.0 * r(2*i,2*j) + 1.0/8.0 * (r(2*i,2*j-1)+r(2*i,2*j+1)+r(2*i-1,2*j)+r(2*i+1,2*j)) + &
                & 1.0/16.0 * (r(2*i+1,2*j+1)+r(2*i-1,2*j+1)+r(2*i+1,2*j-1)+r(2*i-1,2*j-1))
         end do
      end do

      deallocate( r, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector r in restriction, status=", st, "!"
         call f90fflush()
      end if

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "restriction( u, r0, level ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine restriction

   subroutine prolongation( u, dx, level )
      ! in/out
      REAL(kind=8), dimension(:,:) :: u, dx         ! u=outMatrix, dx=inMatrix
      INTEGER(kind=4) :: level
      ! additional
      INTEGER(kind=4) :: i, j, n, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "prolongation( u, dx, level ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      n = 2**level + 1

      !CALL alloc( u, n, n, "u in prolong" )

      u(1:n:2,1:n:2) = dx(1:2**(level-1)+1,1:2**(level-1)+1)

      !CALL dealloc( dx, "dx" )

      do i=2, n, 2
         do j=1, n, 2
            u(i,j) = 1.0/2.0 * (u(i-1,j)+u(i+1,j))
            u(j,i) = 1.0/2.0 * (u(j,i-1)+u(j,i+1))
         end do
      end do
      do j=2, n, 2
         do i=2, n, 2
            u(i,j) = 1.0/4.0 * (u(i-1,j-1)+u(i-1,j+1)+u(i+1,j-1)+u(i+1,j+1))
         end do
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "prolongation( u, dx, level ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine prolongation

!   subroutine removeMatrixStruct( struct )
!      ! in/out
!      type(matrixStruct), dimension(:), allocatable :: struct
!      ! additional
!      INTEGER(kind=4) :: i, st, z3, z4
!
!      if( INFO .OR. INFOTIME ) then
!         write(*,*) "removeMatrixStruct( struct ) in"
!         call system_clock( z3 )
!         call f90fflush()
!      end if
!
!      do i=1, size(struct), 1
!         deallocate(struct(i)%matrix, stat=st)
!         if( st/=0 ) write(*,fmt='(A,I0,A,I0,A)') "Error: Deallocation of the matrix for level=", i, &
!                                                  & " not possible, status=", st, "!"
!      end do
!
!      deallocate(struct, stat=st)
!      if( st/=0 ) write(*,fmt='(A,I0,A)') "Error: Deallocation of the struct not possible, status=", st, "!"
!
!      if( INFO .OR. INFOTIME ) then
!         call system_clock( z4 )
!         write(*,*) "removeMatrixStruct( struct ) out, time for function: ", z4-z3
!         call f90fflush()
!      end if
!   end subroutine removeMatrixStruct

   subroutine printMatrixStruct( struct )
      ! in/out
      type(matrixStruct), dimension(:) :: struct
      ! additional
      INTEGER(kind=4) :: i, row, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "printMatrixStruct( struct ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      do i=1, size(struct), 1
         write(*,fmt='(A,I0,A)') "Matrix of Struct[", i, "] = "
         do row=1, size(struct(i)%matrix(:,1)), 1
            write(*,*) struct(i)%matrix(row,:)
         end do
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "printMatrixStruct( struct ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine printMatrixStruct

   subroutine writeOutput( outputform, level0, solution, L1, L2 )
      ! in/out
      INTEGER(kind=4) :: outputform, level0
      REAL(kind=8), dimension(:) :: solution
      REAL(kind=8) :: L1, L2
      ! additional
      REAL(kind=8), dimension(:), allocatable :: x1, x2
      INTEGER(kind=4) :: i, j, N1, st, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "writeOutput( outputform, level0, solution, L1, L2 ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      N1 = 2**level0+1

      !CALL alloc( x1, N1, "x1 in writeOutput" )
      allocate( x1(1:N1), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector x1 in writeOutput, status=", st, "!"
         call f90fflush()
         stop
      end if
      x1 = 0

      !CALL alloc( x2, N1, "x2 in writeOutput" )
      allocate( x2(1:N1), stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Allocation of the vector x2 in writeOutput, status=", st, "!"
         call f90fflush()
         stop
      end if
      x2 = 0

      CALL get_x1( x1, N1, L1)
      CALL get_x2( x2, N1, L2)

      if( outputform==1 ) then
         open( unit=100, file="output.xyz", iostat=st, status='replace', position='rewind', action='write' )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Opening file output.xyz, status=", st, "!"
            call f90fflush()
         end if
         open( unit=200, file="output.plt", iostat=st, status='replace', position='rewind', action='write' )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Opening file output.plt, status=", st, "!"
            call f90fflush()
         end if

         ! write output.xyz
         do j=1, size(x2), 1
            do i=1, size(x1), 1
               write(100,fmt='(E21.15,A,E21.15,A,E21.15)') x1(i), " ", x2(j), " ", solution((j-1)*N1+i)
            end do
         end do

         ! write output.plt version 1
         !write(200,fmt='(A)') "set pm3d"
         !write(200,fmt='(A,I0,A,I0,A)') "set dgrid3d ",N1,", ",N1,", 1"
         !write(200,fmt='(A)') "splot 'output.xyz' with pm3d"
         !write(200,fmt='(A)') "pause -1"

         ! write output.plt version 2
         write(200,fmt='(A)') "set pm3d at b"
         write(200,fmt='(A,I0,A,I0,A)') "set dgrid3d ",N1,", ",N1,", 1"
         write(200,fmt='(A)') "splot 'output.xyz' with lines"
         write(200,fmt='(A)') "pause -1"

         close( unit=100, iostat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Closing file output.xyz, status=", st, "!"
            call f90fflush()
         end if
         close( unit=200, iostat=st )
         if( st/=0 ) then
            write(*,fmt='(A,I0,A)') "Error: Closing file output.plt, status=", st, "!"
            call f90fflush()
         end if
      end if

      !CALL dealloc( x1, "x1 in writeOutput" )
      deallocate( x1, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector x1 in writeOutput, status=", st, "!"
         call f90fflush()
      end if

      !CALL dealloc( x2, "x2 in writeOutput" )
      deallocate( x2, stat=st )
      if( st/=0 ) then
         write(*,fmt='(A,I0,A)') "Error: Deallocation of the vector x2 in writeOutput, status=", st, "!"
         call f90fflush()
      end if

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "writeOutput( outputform, level0, solution, L1, L2 ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine writeOutput

   function calcFlop(level0, counter, v1, v2)
      ! in/out
      INTEGER(kind=4) :: level0, counter, v1, v2
      REAL(kind=8) :: calcFlop
      ! additional
      INTEGER(kind=4) :: i
      REAL(kind=8) flop, N

      flop = 0

      ! flop in my2dPoisson_without_sparse
      N = real( (2**level0+1)**2 )	! size of a vector, example solution
      flop = flop + 2*N*N	! MatVecMult
      flop = flop + N		! b-r
      flop = flop + N + 2	! abs and res2

      ! MGV (level/=1)
      N = real( (2**1+1)**2 )
      flop = flop + 2*N*N

      ! MGV (level/=1)
      do i=level0, 2, -1
         ! jacobi
         N = real( (2**i+1)**2 )
         flop = flop + N					! D_inv
         flop = flop + v1 * ( 2*N*N + N + 2*N*N + N + N )	! second loop

         flop = flop + 2*N*N	! MatVecMult
         flop = flop + N	! b-r

         ! restriction
         !r0 -> N, level -> i, n -> 2**(i-1) + 1
         flop = flop + 14 * real((2**(i-1)+1)) * real((2**(i-1)+1))

         ! prolongation
         !dx -> (2**(i-1)+1)**2, level -> i, n -> 2**i + 1
         flop = flop + 6 * (real(2**i+1)/2) * (real(2**i+1)/2 + 1)
         flop = flop + 5 * (real(2**i+1)/2) * (real(2**i+1)/2)

         flop = flop + N	! x+temp_vec

         ! jacobi
         flop = flop + N					! D_inv
         flop = flop + v2 * ( 2*N*N + N + 2*N*N + N + N )	! second loop
      end do

      calcFlop = counter * flop
   end function calcFlop

   subroutine MatVecMult( out_vector, matrix, vector )
      ! in/out
      REAL(kind=8), dimension(:) :: out_vector
      REAL(kind=8), dimension(:,:) :: matrix
      REAL(kind=8), dimension(:) :: vector
      ! additional
      INTEGER(kind=4) :: i, j, z3, z4

      if( INFO .OR. INFOTIME ) then
         write(*,*) "MatVecMult( out_vector, matrix, vector ) in"
         call system_clock( z3 )
         call f90fflush()
      end if

      out_vector = 0

      do i=1, size(matrix(1,:)), 1
         do j=1, size(matrix(:,1)), 1
            out_vector(j) = out_vector(j) + matrix(j,i) * vector(i)
         end do
      end do

      if( INFO .OR. INFOTIME ) then
         call system_clock( z4 )
         write(*,*) "MatVecMult( out_vector, matrix, vector ) out, time for function: ", z4-z3
         call f90fflush()
      end if
   end subroutine MatVecMult

end module my2dPoisson

!************ main programm routines ************

!************ main programm entry ************

subroutine fortran_entry(  level0, maxlevel0, outputform, v1, v2, &
                                       & w, L1, L2, time_for_MGV, omega, flop  )
   use my2dPoisson

   ! in/out
   INTEGER(kind=4) :: level0, maxlevel0, outputform, v1, v2
   REAL(kind=8) :: w, L1, L2
   REAL(kind=8) :: time_for_MGV, omega, flop

   CALL my2dPoisson_without_sparse( level0, maxlevel0, outputform, v1, v2, w, L1, L2, time_for_MGV, omega, flop )
end subroutine fortran_entry

!************ main programm entry ************


      SUBROUTINE EZFFT1 (N,WA,IFAC)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       WA(*)      ,IFAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
     1    ,TPI/6.28318530717958647692D0/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      ARGH = TPI/FLOAT(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 111 K1=1,NFM1
         IP = IFAC(K1+2)
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         ARG1 = FLOAT(L1)*ARGH
         CH1 = 1.0D0
         SH1 = 0.0D0
         DCH1 = COS(ARG1)
         DSH1 = SIN(ARG1)
         DO 110 J=1,IPM
            CH1H = DCH1*CH1-DSH1*SH1
            SH1 = DCH1*SH1+DSH1*CH1
            CH1 = CH1H
            I = IS+2
            WA(I-1) = CH1
            WA(I) = SH1
            IF (IDO .LT. 5) GO TO 109
            DO 108 II=5,IDO,2
               I = I+2
               WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2)
               WA(I) = CH1*WA(I-2)+SH1*WA(I-3)
  108       CONTINUE
  109       IS = IS+IDO
  110    CONTINUE
         L1 = L2
  111 CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION GFACT(QQ)
      IMPLICIT NONE
C factor G to be used as inteligent retabulation as in paper
C Kuhn Santamaria
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
      DOUBLE PRECISION DGAMQQ,QQ,THR,THU,TH0,LAM
      INTEGER II,INIT,INUM
      DOUBLE PRECISION AF4,AF5,AA1,AA2,AA4
      DOUBLE PRECISION F1,F2,F3,F4,F5
      DOUBLE PRECISION AA,BB,CC,DD,A,B,C,D,X
      SAVE A,B,C,D,AF4,AF5,AA,BB,CC,DD,THR,THU,TH0

      CALL IFGFACT(1,II,INIT)
      IF(INIT.EQ.0) THEN
       THR=(AMPI+AMRO)**2
       TH0=9*AMPI**2
       THU=THR
       CALL getFF3PISCAL(INUM)  ! we switch off part of the contr to 3 pi mode
       CALL setFF3PISCAL(0)
C below THR , we calculate at distance 1/4 1/2 and 1 between
C minimum and maximum for this range
       LAM=(THR-TH0)/4
       AA1=DGAMQQ(TH0+  LAM)
       AA2=DGAMQQ(TH0+2*LAM)
       AA4=DGAMQQ(TH0+4*LAM)
C above THR we calculate at THR times 1 2 3 and 4 for higher range
       F1=DGAMQQ(THU)
       F2=DGAMQQ(1.5*THU)
       F3=DGAMQQ(2.*THU)
       F4=DGAMQQ(3*THU)
       F5=DGAMQQ(3.5*THU)
       CALL setFF3PISCAL(INUM) ! we switch back part of the contr to 3 pi mode

C we calculate coefs for expansion  ( polynomial of order 2 once
C                                     X**2 factorized out, X=QQ-TH0 )

       AA1 = AA1/LAM**2            ! RESCALING due to factorized X**2
       AA2 = AA2/(2.*LAM)**2       !
       AA4 = AA4/(4.*LAM)**2       !

       BB=1./8.*(10.*AA2-AA4-16.*AA1)
       AA=(8.*AA1-AA2-4.*BB)/6.
       CC=AA1-AA-BB
       AA=AA/LAM
       BB=BB/LAM**2
       CC=CC/LAM**3
C calulate coefs, assuming it is polynomial order 3 note negative pwrs
       D=-9*(-4*F3-F1+4*F2+F4)
       C=3*(F4+F1-2*F3-11./18.*D)
       A=F3-F1+0.5*C+0.75*D
       B=F1-A-C-D
       A=A/THU
       B=B
       C=C*THU
       D=D*THU**2
       AF4=F4
       AF5=F5
c       write(*,*) "A=",AA,"B=",-BB,"C=",CC,"D=",A,"E=",-B,"F=",C
c       write(*,*) "G=",-D,"H=",AF4,"P=",AF5-AF4
      ENDIF
      IF (QQ.GT.3*THU) THEN
        GFACT=AF4+(AF5-AF4)*(QQ-3*THU)*2/THU
      ELSEIF (QQ.GT.THR) THEN
        GFACT=A*QQ+B+C/QQ+D/QQ**2
      ELSEIF(QQ.LE.TH0) THEN
        GFACT=0.0
      ELSE
        X=QQ-TH0
        GFACT=AA*X+BB*X**2+CC*X**3
        GFACT=X**2*GFACT
      ENDIF
      END

      DOUBLE PRECISION FUNCTION DGAMQQ(XQQB)
C **************************************************************
C     calculates \tau^- -> pi^- pi^- pi^+ nu width as function of QQ (XQQB)
C     formulas (19) of ref [2a] integration over S1
C     limit of integration (21) of ref [2a]  see also [4]
C     called from main function
C **************************************************************
      IMPLICIT NONE
      COMMON/PRECINT/          EPSSQ,ABS1
      DOUBLE PRECISION         EPSSQ,ABS1
      COMMON /EXTERNAL/ XQQA
      DOUBLE PRECISION  XQQA
      EXTERNAL          GAUS,DGAMQQS1
      DOUBLE PRECISION  GAUS,DGAMQQS1
      DOUBLE PRECISION  XQQB,EPS,UPS1,DOWNS1
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST

      XQQA = XQQB
      EPS = EPSSQ/3.D0
      UPS1=(DSQRT(XQQB) - AMPI)**2-ABS1              ! limits on S1
      DOWNS1=4.D0*AMPI**2+ABS1

      DGAMQQ = GAUS(DGAMQQS1,DOWNS1,UPS1,EPS)

      RETURN
      END

      DOUBLE PRECISION FUNCTION DGAMQQS1(S1)
      IMPLICIT NONE
      DOUBLE PRECISION                   S1
C **************************************************************
C     calculates \tau^- -> pi^- pi^- pi^+ nu width
C           as function of QQ,S1
C     GAUS integrant in DGAMQQ (XQQA- hidden argument)
C     calculates tau^- -> pi^- pi^- pi^+ nu spectrum as function of S1
C     formulas (19) of ref [2a] see also [4]
C     limit of integration (21) of ref [2a]
C **************************************************************
      EXTERNAL          GAUS2,FFWID3PI,DGAMQQS1S3
      DOUBLE PRECISION  GAUS2,FFWID3PI,DGAMQQS1S3
      COMMON /INTERNAL/ S1A
      DOUBLE PRECISION  S1A
      COMMON /EXTERNAL/   XQQA
      DOUBLE PRECISION    XQQA
      COMMON/PRECINT/          EPSSQ,ABS1
      DOUBLE PRECISION         EPSSQ,ABS1
      DOUBLE PRECISION EPS,UPS3,DOWNS3
      DOUBLE PRECISION XLAM,X,Y,Z
      DOUBLE PRECISION XAMPI2
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST

      Xlam(x,y,z) = sqrt(abs((x-y-z)**2 - 4.*y*z))
      S1A = S1
      EPS = EPSSQ/9.D0
      XAMPI2=AMPI**2

      UPS3 = (XQQA - AMPI**2)**2 -                              ! limits on S3
     &    ( XLAM(XQQA,S1,XAMPI2)
     &         - XLAM(S1,XAMPI2,XAMPI2) )**2
      DOWNS3 = (XQQA - AMPI**2)**2 -
     &    (XLAM(XQQA,S1,XAMPI2)
     &          + XLAM(S1,XAMPI2,XAMPI2) )**2

      UPS3 = UPS3/4./S1
      DOWNS3 = DOWNS3/4./S1

      DGAMQQS1 = GAUS2(DGAMQQS1S3,DOWNS3,UPS3,EPS)

      RETURN
      END

      DOUBLE PRECISION FUNCTION DGAMQQS1S3(XS3)
      IMPLICIT NONE
C **************************************************************
C     calculates \tau^- -> pi^- pi^- pi^+ nu width
C           as function of QQ,S1,S3
C **************************************************************
C      EXTERNAL          GAUS2,FFWID3PI
      DOUBLE PRECISION  FFWID3PI,XS3
      COMMON /INTERNAL/ XS1A
      DOUBLE PRECISION  XS1A
      COMMON /EXTERNAL/   XQQA
      DOUBLE PRECISION    XQQA
      COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST
C
      REAL*4            AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
     *                 ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
     *                 ,AMK,AMKZ,AMKST,GAMKST

      DGAMQQS1S3 = FFWID3PI(XQQA,XS1A,XS3)

      RETURN

      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(:,:,:),
     1   hesstarg(:,:,:)
      character(len=72) str1

      integer ipass(27)
      integer nd,idim

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

      call prini(6,13)

      done = 1
      pi = atan(done)*4

      nsrc = 4000
      ntarg = nsrc+10

      nd = 3

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

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

        do idim=1,nd
          charges(idim,i) = hkrand(0) + ima*hkrand(0)
          dipstr(idim,i) = hkrand(0) + ima*hkrand(0)

          dipvec(idim,1,i) = hkrand(0)
          dipvec(idim,2,i) = hkrand(0)
        enddo
      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 = 500.0d0
      eps = 0.5d-6

      write(*,*) "=========================================="
      write(*,*) "Testing suite for hfmm2d_vec"
      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_vec(nd,eps,zk,nsrc,sources,charges,
     1        pot,ier)

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

      call comperr_vec(nd,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)

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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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
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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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)

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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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_vec(nd,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 vec testing suite'
      write(33,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in hfmm2d vec testing suite'
      close(33)

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

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

      allocate(potex(nd,ntest),gradex(nd,2,ntest),hessex(nd,3,ntest))
      allocate(pottargex(nd,ntest),gradtargex(nd,2,ntest),
     1   hesstargex(nd,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
        do idim=1,nd
          if(ifpgh.ge.1) then
            potex(idim,i) = 0
          endif
          if(ifpgh.ge.2) then
            gradex(idim,1,i) = 0
            gradex(idim,2,i) = 0
          endif
          if(ifpgh.ge.3) then
            hessex(idim,1,i) = 0
            hessex(idim,2,i) = 0
            hessex(idim,3,i) = 0
          endif
        enddo
      enddo

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

      thresh = 2.0d0**(-51)

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

      call hfmm2dpart_direct(nd,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
        do idim=1,nd
          if(ifpgh.ge.1) then
            erra = erra + abs(pot(idim,i) - potex(idim,i))**2
            ra = ra + abs(potex(idim,i))**2
          endif
          if(ifpgh.ge.2) then
            erra = erra + abs(grad(idim,1,i)-gradex(idim,1,i))**2
            erra = erra + abs(grad(idim,2,i)-gradex(idim,2,i))**2
            ra = ra + abs(gradex(idim,1,i))**2
            ra = ra + abs(gradex(idim,2,i))**2
          endif
          if(ifpgh.ge.3) then
            erra = erra + abs(hess(idim,1,i)-hessex(idim,1,i))**2
            erra = erra + abs(hess(idim,2,i)-hessex(idim,2,i))**2
            erra = erra + abs(hess(idim,3,i)-hessex(idim,3,i))**2
            ra = ra + abs(hessex(idim,1,i))**2
            ra = ra + abs(hessex(idim,2,i))**2
            ra = ra + abs(hessex(idim,3,i))**2
          endif
        enddo
      enddo

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

      erra = sqrt(erra/ra)

      return
      end


*DECK CSINH
      COMPLEX FUNCTION CSINH (Z)
C***BEGIN PROLOGUE  CSINH
C***PURPOSE  Compute the complex hyperbolic sine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      COMPLEX (CSINH-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, HYPERBOLIC SINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CSINH(Z) calculates the complex hyperbolic sine of complex
C argument Z.  Z is in units of radians.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CSINH
      COMPLEX Z, CI
      SAVE CI
      DATA CI /(0.,1.)/
C***FIRST EXECUTABLE STATEMENT  CSINH
      CSINH = -CI*SIN(CI*Z)
C
      RETURN
      END