module supralu_mod

  ! Column-compressed-storage based sparse matrix container

  implicit none
  integer, parameter, private :: r8 = selected_real_kind(12,100)
  character(*), parameter, private :: version = &
       & '$Id: supralu_mod.f90,v 1.4 2003/12/22 17:24:29 pletzer Exp $'
  
  type sparseC16_obj
     integer, pointer :: irow(:)
     integer, pointer :: jcol_ptr(:)
     complex(r8), pointer :: values(:)
     integer :: size, size_ptr, nnz, col_counter
     integer :: base

     ! SuperLU stuff

     ! column permutation specification
     !   permc_spec = 0: natural ordering 
     !   permc_spec = 1: minimum degree on structure of A'*A
     !   permc_spec = 2: minimum degree on structure of A'+A
     !   permc_spec = 3: approximate minimum degree for unsymmetric matrices
     integer :: permc_spec 
     
  end type sparseC16_obj

  type sparseR8_obj
     integer, pointer :: irow(:)
     integer, pointer :: jcol_ptr(:)
     real(r8), pointer :: values(:)
     integer :: size, size_ptr, nnz, col_counter
     integer :: base

     ! SuperLU stuff

     ! column permutation specification
     !   permc_spec = 0: natural ordering 
     !   permc_spec = 1: minimum degree on structure of A'*A
     !   permc_spec = 2: minimum degree on structure of A'+A
     !   permc_spec = 3: approximate minimum degree for unsymmetric matrices
     integer :: permc_spec 
     
  end type sparseR8_obj

  contains
!===================================================================================

! complex*16

    subroutine sparseC16_init(this, rank, size, base, ier)

      ! Constructor.
      !
      ! rank: matrix rank (or approximation if not known)
      ! size: >= no of non-zero values to store. If 
      ! size turns out to be too tight, fresh arrays will be 
      ! reallocated and the data will be copied, however this may
      ! can cause performance degradation.
      !
      ! base: indexing base (0 like C or 1 like Fortran)

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: rank
      integer, intent(in) :: size
      integer, intent(in) :: base
      integer, intent(out) :: ier

      integer jer

      ier = 0

      this % permc_spec = 2 ! seems to work best

      this % nnz = 0
      this % size_ptr = rank+1
      this % size = size
      this % base = base
      this % col_counter = 0
      allocate(this%irow(this%size), stat=jer)
      if(jer /= 0 ) then
         ier = 9
         return
      end if
      allocate(this%values(this%size), stat=jer)
      if(jer /= 0 ) then
         ier = 10
         return
      end if
      allocate(this%jcol_ptr(this%size_ptr), stat=jer)
      if(jer /= 0 ) then
         ier = 11
         return
      end if
      this%irow = 0
      this%jcol_ptr = 0
      this%values = 0
      if(jer /=0 ) ier = 1
      
    end subroutine sparseC16_init
    
    subroutine sparseC16_free(this, ier)

      ! Destructor

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(out) :: ier

      integer jer

      ier = 0
      deallocate(this%irow, stat=jer)
      deallocate(this%values, stat=jer)
      deallocate(this%jcol_ptr, stat=jer)
      if(jer/=0) ier = 2
      
    end subroutine sparseC16_free

    subroutine sparseC16_copy(this, that, ier)

      ! Copy this into that. that should be unitialized.

      implicit none
      type(sparseC16_obj) :: this, that
      integer, intent(out) :: ier

      integer jer

      ier = 0
      that % nnz = this % nnz
      that % size_ptr = this % size_ptr
      that % size = this % size
      that % base = this % base
      that % col_counter = this % col_counter
      allocate(that%irow(that%size), stat=jer)
      if(jer /= 0 ) then
         ier = 9
         return
      end if
      allocate(that%values(that%size), stat=jer)
      if(jer /= 0 ) then
         ier = 10
         return
      end if
      allocate(that%jcol_ptr(that%size_ptr), stat=jer)
      if(jer /= 0 ) then
         ier = 11
         return
      end if
      that % irow = this%irow
      that % jcol_ptr = this%jcol_ptr
      that % values = this%values
      if(jer /=0 ) ier = 12
      
      
    end subroutine sparseC16_copy

    subroutine sparseC16_compare_shapes(this, that, ier)

      ! Compare two sparse matrices

      implicit none
      type(sparseC16_obj) :: this, that
      integer, intent(out) :: ier

      integer i

      ier = 0
      if(this%base /= that%base) then
         ier = 13
         return
      end if
      if(this%nnz /= that%nnz) then
         ier = 14
         return
      end if
      if(this%size_ptr /= that%size_ptr) then
         ier = 15
         return
      end if
      if(this%size /= that%size) then
         ier = 16
         return
      end if
      if(this%col_counter /= that%col_counter) then
         ier = 17
         return
      end if
      do i = 1, this%size_ptr
         if(this%jcol_ptr(i) /= that%jcol_ptr(i)) then
            ier = 18
            return 
         end if
      enddo
      do i = 1, this%size
         if(this%irow(i) /= that%irow(i)) then
            ier = 19
            return      
         end if
      enddo


    end subroutine sparseC16_compare_shapes

    subroutine sparseC16_set_next(this, row, newcol_flag, value, ier)

      ! Set next value. Must iterate down each column 
      ! running from left to right.
      !
    
      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: row 
      logical, intent(in) :: newcol_flag ! .TRUE. if new column, .FALSE. otherwise
      complex(r8), intent(in) :: value 
      integer, intent(out) :: ier

      ier = 0
      this % nnz = this % nnz + 1
      if(this % nnz > this % size) then         
         ier = 3
         return
      endif
      this % irow(this%nnz) = row
      this % values(this%nnz) = value
      if(newcol_flag) then
         this % col_counter = this % col_counter + 1
         this % jcol_ptr(this % col_counter) = this%nnz - 1 + this%base
      endif
      this % jcol_ptr(this % col_counter+1) = this%nnz + this%base
      
    end subroutine sparseC16_set_next

    subroutine sparseC16_get_size(this, nrows, ncols, ier)

      ! Return no of rows and columns

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(out) :: nrows, ncols
      integer, intent(out) :: ier

      ier = 0
      nrows = maxval(this % irow)
      ncols = this % col_counter
    end subroutine sparseC16_get_size

    subroutine sparseC16_solve(this, rhs, ier)

      ! Solve matrix system
      
      implicit none
      type(sparseC16_obj) :: this
      complex(r8), intent(inout) :: rhs(:) ! right-hand side vector, solution vector upon return
      integer, intent(out) :: ier

      integer n, jer
      integer :: handle(8) ! opaque handle

      ier = 0
      n = size(rhs)

      ! note: we pass here address (1) of vectors to force passing the 
      ! arguments by reference. 
      call zsupralu_new(handle, &
           & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, n, &
           & jer)
      call zsupralu_colperm(handle, this % permc_spec, jer)
      call zsupralu_lu(handle, jer)
      call zsupralu_solve(handle, rhs(1), jer)
      call zsupralu_del(handle, jer)

      if(jer/=0) ier = 8

    end subroutine sparseC16_solve

    subroutine sparseC16_det(this, res_mantissa, res_exponent, ier)

      ! Return the determinant of A in the form of 
      !
      ! res_mantissa * 2**res_exponent

      implicit none
      type(sparseC16_obj) :: this
      complex(r8), intent(out) :: res_mantissa
      integer, intent(out) :: res_exponent
      integer, intent(out) :: ier
      
      integer :: handle(8) ! opaque handle
      integer :: n, jer

      ier = 0
      n = this % col_counter
      call zsupralu_new(handle, &
           & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, n, &
           & jer)
      call zsupralu_colperm(handle, this % permc_spec, jer)
      call zsupralu_lu(handle, jer)
      call zsupralu_determinant(handle, res_mantissa, res_exponent, jer)
      call zsupralu_del(handle, jer)
      if(jer/=0) ier = 20

    end subroutine sparseC16_det

    subroutine sparseC16_eigen(Amat, Bmat, x, lambda, tol, nmax, ier)

      ! Solve A * x = lambda B * x by inverse iterations

      implicit none
      type(sparseC16_obj) :: Amat, Bmat ! Must have the same sparsity pattern! 
      complex(r8), intent(inout) :: lambda ! initial guess/computed eigenvalue
      complex(r8), intent(inout) :: x(:) ! initial egenvector guess/computed eigenvector
      real(r8), intent(inout) :: tol ! tolerance
      integer, intent(inout) :: nmax ! max number of iterations      
      integer, intent(out) :: ier

      integer n, i
      complex(r8), allocatable :: rhs(:)
      real(r8) :: residue, norm
      complex(r8) :: newv_b_v, newv_b_newv
      type(sparseC16_obj) :: Cmat

      ier = 0
      n = size(x)
      allocate(rhs(n))
      call sparseC16_copy(Amat, Cmat, ier)
      
      do i = 1, nmax
         Cmat % values = Amat % values - lambda * Bmat % values
         call sparseC16_A_dot_x(Cmat, x, rhs, ier)
         residue = sqrt( dot_product(rhs, rhs) )
         if(residue < tol) exit
         
         call sparseC16_A_dot_x(Bmat, x, rhs, ier)
         x = rhs
         call sparseC16_save(Cmat, 'cmat.nc', ier)
         call sparseC16_solve(Cmat, x, ier)
         newv_b_v = dot_product(x, rhs)
         call sparseC16_A_dot_x(Bmat, x, rhs, ier)
         newv_b_newv = dot_product(x, rhs)
         lambda = lambda + newv_b_v/newv_b_newv
         print *,'iteration=', i,' lambda=', lambda, ' residue=', residue
         
         norm = sqrt(dot_product(x, x))
         x = x/norm
      end do
      nmax = i
      tol = residue

      call sparseC16_free(Cmat, ier)
      deallocate(rhs)

    end subroutine sparseC16_eigen

    subroutine sparseC16_A_dot_x(this, x, res, ier)

      ! matrix . x => res

      implicit none
      type(sparseC16_obj) :: this
      complex(r8), intent(in) :: x(:) ! vector
      complex(r8), intent(out) :: res(:) ! result
      integer, intent(out) :: ier

      integer i, k, rank, j

      ier = 0
      res = 0
      rank = maxval(this % irow) + 1 - this%base

      
      do j = this%base+1, rank
         do k = this%jcol_ptr(j)+1-this%base, this%jcol_ptr(j+1)-this%base
            i = this%irow(k) + 1 - this%base
            res(i) = res(i) + this%values(k)*x(j)
         enddo
      enddo
      
    end subroutine sparseC16_A_dot_x

    subroutine sparseC16_save(this, filename, ier)

    ! Save state in netCDF file 'filename'

    use ezcdf
    implicit none
    type(sparseC16_obj) :: this
    character(*), intent(in) :: filename
    integer, intent(out) :: ier

    integer ncid, jer
    ier = 0

    call cdf_open(ncid, filename, 'w', jer)

    call cdf_define(ncid, 'version', (/len_trim(version),0,0/), 'CHAR', jer)
    call cdf_define(ncid, 'size', this%size, jer)
    call cdf_define(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_define(ncid, 'nnz', this%nnz, jer)
    call cdf_define(ncid, 'col_counter', this%col_counter, jer)
    call cdf_define(ncid, 'base', this%base, jer)
    call cdf_define(ncid, 'irow', this%irow(1:this%nnz), jer)
    call cdf_define(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_define(ncid, 'values', this%values(1:this%nnz), jer)

    call cdf_write(ncid, 'version', version, jer)
    call cdf_write(ncid, 'size', this%size, jer)
    call cdf_write(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_write(ncid, 'nnz', this%nnz, jer)
    call cdf_write(ncid, 'col_counter', this%col_counter, jer)
    call cdf_write(ncid, 'base', this%base, jer)
    call cdf_write(ncid, 'irow', this%irow(1:this%nnz), jer)
    call cdf_write(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_write(ncid, 'values', this%values(1:this%nnz), jer)

    call cdf_close(ncid, jer) 
    if(jer /= 0) ier = 4

    end subroutine sparseC16_save

    subroutine sparseC16_load(this, filename, ier)

      ! Load state from netCDF file 'filename'

    use ezcdf
    implicit none
    type(sparseC16_obj) :: this
    character(*), intent(in) :: filename
    integer, intent(out) :: ier

    integer ncid, jer
    ier = 0

    call cdf_open(ncid, filename, 'r', jer)

    call cdf_read(ncid, 'size', this%size, jer)
    call cdf_read(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_read(ncid, 'nnz', this%nnz, jer)
    call cdf_read(ncid, 'col_counter', this%col_counter, jer)
    call cdf_read(ncid, 'base', this%base, jer)
    allocate(this % irow(this%size), stat=jer)
    allocate(this % jcol_ptr(this%size_ptr), stat=jer)
    allocate(this % values(this%size), stat=jer)
    if(jer /= 0) then 
       ier = 1
       return
    endif
    call cdf_read(ncid, 'irow', this%irow, jer)
    call cdf_read(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_read(ncid, 'values', this%values, jer)

    call cdf_close(ncid, jer) 
    if(jer /= 0) ier = 5
      
    end subroutine sparseC16_load

    subroutine sparseC16_test(this, ier)

      ! Test unit

      implicit none
      type(sparseC16_obj) :: this, that, amat, bmat
      integer, intent(out) :: ier

      integer rank, size, base, i, nmax
      real(r8) :: tol
      complex(r8), allocatable :: rhs(:), x(:), res(:), y(:)
      complex(r8) :: lambda, adet, bdet, adet_mantissa, bdet_mantissa
      integer :: adet_exponent, bdet_exponent
      real(r8) :: cum_error

      ier = 0
      cum_error = 0
      print *, 'testing sparseC16...', version

      base = 0 ! C-like
      rank = 5
      size = 10
      call sparseC16_init(this, rank, size, base, ier)
      ! matrix to store
      ! [ 0 2 x 7 x ]
      ! [ 1 3 x x x ]
      ! [ x x 4 x x ]
      ! [ x x 5 8 x ]
      ! [ x x 6 x 9 ]
      ! the result should be 
      ! irow = [0,1,0,1,2,3,4,0,3,4]
      ! jcol_ptr = [0,2,4,7,9]
      ! values = [0,1,2,3,4,5,6,7,8,9]
      print *, '...assembling'
      call sparseC16_set_next(this, 0, .TRUE., cmplx(0., 0., r8), ier)
      call sparseC16_set_next(this, 1, .FALSE., cmplx(1., 0., r8), ier)
      call sparseC16_set_next(this, 0, .TRUE., cmplx(2., 0., r8), ier)
      call sparseC16_set_next(this, 1, .FALSE., cmplx(3., 0., r8), ier)
      call sparseC16_set_next(this, 2, .TRUE., cmplx(4., 0., r8), ier)
      call sparseC16_set_next(this, 3, .FALSE., cmplx(5., 0., r8), ier)
      call sparseC16_set_next(this, 4, .FALSE., cmplx(6., 0., r8), ier)
      call sparseC16_set_next(this, 0, .TRUE., cmplx(7., 0., r8), ier)
      call sparseC16_set_next(this, 3, .FALSE., cmplx(8., 0., r8), ier)
      call sparseC16_set_next(this, 4, .TRUE., cmplx(9., 0., r8), ier)
!!$
!!$      call sparseC16_set_next(this, 0, .TRUE., cmplx(1., 0., r8), ier)
!!$      call sparseC16_set_next(this, 1, .TRUE., cmplx(2., 0., r8), ier)
!!$      call sparseC16_set_next(this, 2, .TRUE., cmplx(3., 0., r8), ier)
!!$      call sparseC16_set_next(this, 3, .TRUE., cmplx(4., 0., r8), ier)
!!$      call sparseC16_set_next(this, 4, .TRUE., cmplx(5., 0., r8), ier)      

      print *, '...saving'
      call sparseC16_save(this, 'sparseC16.nc', ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'...freeing'
      call sparseC16_free(this, ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'...loading'
      call sparseC16_load(this, 'sparseC16.nc', ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *, '...saving'
      call sparseC16_save(this, 'sparseC16_2.nc', ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      allocate(rhs(rank), x(rank), res(rank))
      rhs = (/ (i, i=1,rank) /)
      x = rhs
      print *, '...solving'
      call sparseC16_solve(this, x, ier)      
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'...checking'
      call sparseC16_A_dot_x(this, x, res, ier)
!!$      print *,'result=', x
      print *,'error = ', sqrt(abs(sum((res - rhs)**2)/rank))
      cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))

      print *,'...copying'
      call sparseC16_copy(this, that, ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'***********************************************************'
      print *,'CUMULATIVE ERROR = ', cum_error
      if(cum_error > 1.e-10_r8) then
         print *,' **TEST FAILED**'
      else
         print *,' TEST SUCCEEDED '
      endif
      print *,'***********************************************************'

      that % values = 2 * this % values
      lambda = 0.5_r8
      nmax = 10
      print *,'...solving eigenvalue problem'
      tol = 1.e-10_r8
      call sparseC16_eigen(this, that, x, lambda, tol, nmax, ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'lambda = ', lambda
      print *,'x=', x
      print *,'tol=', tol
      print *,'nmax=', nmax

      call sparseC16_free(this, ier)
      call sparseC16_free(that, ier)

! following is matlab code
!!$>> amat=[1+i -1 0; -1 2 3; 0 1 1.];
!!$>> bmat=[1 0.5 0; 0.5 1 0.5; 0 0.5 1];
!!$>> format long
!!$>> det(amat)
!!$
!!$ans =
!!$
!!$   -2.00000000000000 - 1.00000000000000i
!!$
!!$
!!$>> det(bmat)
!!$
!!$ans =
!!$
!!$    0.5000
!!$
!!$>> eig(amat, bmat)
!!$
!!$ans =
!!$
!!$   4.71566270818199 + 1.09633481548510i
!!$   1.09003448414007 + 0.34566426719211i
!!$  -0.80569719232206 + 0.05800091732279i

      call sparseC16_init(amat, 3, 7, 0, ier)
      call sparseC16_set_next(amat, 0, .TRUE.,  cmplx( 1., 1., r8), ier)
      call sparseC16_set_next(amat, 1, .FALSE., cmplx(-1., 0., r8), ier)
      call sparseC16_set_next(amat, 0, .TRUE.,  cmplx(-1., 0., r8), ier)
      call sparseC16_set_next(amat, 1, .FALSE., cmplx( 2., 0., r8), ier)
      call sparseC16_set_next(amat, 2, .FALSE., cmplx( 1., 0., r8), ier)
      call sparseC16_set_next(amat, 1, .TRUE.,  cmplx( 3., 0., r8), ier)
      call sparseC16_set_next(amat, 2, .FALSE., cmplx( 1., 0., r8), ier)
      cum_error = cum_error + ier

      call sparseC16_init(bmat, 3, 7, 0, ier)
      call sparseC16_set_next(bmat, 0, .TRUE.,  cmplx( 1., 0., r8), ier)
      call sparseC16_set_next(bmat, 1, .FALSE., cmplx( .5, 0., r8), ier)
      call sparseC16_set_next(bmat, 0, .TRUE.,  cmplx( .5, 0., r8), ier)
      call sparseC16_set_next(bmat, 1, .FALSE., cmplx( 1., 0., r8), ier)
      call sparseC16_set_next(bmat, 2, .FALSE., cmplx( .5, 0., r8), ier)
      call sparseC16_set_next(bmat, 1, .TRUE.,  cmplx( .5, 0., r8), ier)
      call sparseC16_set_next(bmat, 2, .FALSE., cmplx( 1., 0., r8), ier)
      cum_error = cum_error + ier

      amat % permc_spec = 2
      call sparseC16_det(amat, adet_mantissa, adet_exponent, ier)
      call sparseC16_det(bmat, bdet_mantissa, bdet_exponent, ier)
      adet = adet_mantissa * 2._r8**adet_exponent
      bdet = bdet_mantissa * 2._r8**bdet_exponent
      print *,'det A = ', adet, ' det B = ', bdet
      cum_error = cum_error + abs(adet - cmplx(-2._r8, -1._r8))
      cum_error = cum_error + abs(bdet - cmplx( 0.5_r8, 0._r8))

      allocate(y(3))
      tol = 1.e-10_r8
      nmax = 10
      lambda = -0.8_r8; y = 1
      call sparseC16_eigen(amat, bmat, y, lambda, tol, nmax, ier)
      print *,'lambda = ', lambda
      print *,'x=', x
      print *,'tol=', tol
      print *,'nmax=', nmax
      print *,'-------------------------------------------------'
      cum_error = cum_error + abs(lambda -  cmplx(-0.80569719232206_r8, 0.05800091732279_r8))

      tol = 1.e-10_r8
      nmax = 10
      lambda = 0.5_r8; y = 1
      call sparseC16_eigen(amat, bmat, y, lambda, tol, nmax, ier)
      print *,'lambda = ', lambda
      print *,'x=', x
      print *,'tol=', tol
      print *,'nmax=', nmax
      print *,'-------------------------------------------------'
      cum_error = cum_error + abs(lambda -  cmplx(1.09003448414007_r8, 0.34566426719211_r8))

      tol = 1.e-10_r8
      nmax = 10
      lambda = 4.5_r8; y = 1
      call sparseC16_eigen(amat, bmat, y, lambda, tol, nmax, ier)
      print *,'lambda = ', lambda
      print *,'x=', x
      print *,'tol=', tol
      print *,'nmax=', nmax
      print *,'-------------------------------------------------'
      cum_error = cum_error + abs(lambda -  cmplx(4.71566270818199_r8, 1.09633481548510_r8))

      call sparseC16_free(amat, ier)
      call sparseC16_free(bmat, ier)

      deallocate(rhs, x, res)
      deallocate(y)

      print *,'***********************************************************'
      print *,'CUMULATIVE ERROR = ', cum_error
      if(cum_error > 1.e-6_r8) then
         print *,' **TEST FAILED**'
      else
         print *,' TEST SUCCEEDED '
      endif
      print *,'***********************************************************'

    end subroutine sparseC16_test

    subroutine sparseC16_error(this, nunit, ier)
      
      ! Error handler
      
      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: nunit ! output channel
      integer, intent(in) :: ier
      
      character(*), parameter :: header = 'SparseC16::'

    select case(ier)
       case(1)
          write(nunit, *) header//'ERROR while initializing'
       case(2)
          write(nunit, *) header//'ERROR while deallocating'
       case(3)
          write(nunit, *) &
               & header//'ERROR counter exceeded declared size ', this%size,' rank=', this%size_ptr-1
       case(4)
          write(nunit, *) header//'ERROR while saving'
       case(5)
          write(nunit, *) header//'ERROR while loading'
       case(6)
          write(nunit, *) header//'ERROR occurred in test unit'
       case(7)
          write(nunit, *) header//'ERROR method not implemented'
       case(8)
          write(nunit, *) header//'ERROR occurred in solve'
       case(9)
          write(nunit, *) header//'ERROR occurred when allocating "irow"'
       case(10)
          write(nunit, *) header//'ERROR occurred when allocating "values"'
       case(11)
          write(nunit, *) header//'ERROR occurred when allocating "jcol_ptr"'
       case(12)
          write(nunit, *) header//'ERROR occurred when copying'
       case(13)
          write(nunit, *) header//'WARNING "base" mismatch'
       case(14)
          write(nunit, *) header//'WARNING "nnz" mismatch'
       case(15)
          write(nunit, *) header//'WARNING "size_ptr" mismatch'
       case(16)
          write(nunit, *) header//'WARNING "size" mismatch'
       case(17)
          write(nunit, *) header//'WARNING "col_counter" mismatch'
       case(18)
          write(nunit, *) header//'WARNING "jcol_ptr" array differ'
       case(19)
          write(nunit, *) header//'WARNING "irow" array differ'
       case(20)
          write(nunit, *) header//'ERROR occurred  in det'
       
       case default
    end select    
      
      
    end subroutine sparseC16_error
    
!===================================================================================

! real*8

    subroutine sparseR8_init(this, rank, size, base, ier)

      ! Constructor.
      !
      ! rank: matrix rank (or approximation if not known)
      ! size: >= no of non-zero values to store. If 
      ! size turns out to be too tight, fresh arrays will be 
      ! reallocated and the data will be copied, however this may
      ! can cause performance degradation.
      !
      ! base: indexing base (0 like C or 1 like Fortran)

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: rank
      integer, intent(in) :: size
      integer, intent(in) :: base
      integer, intent(out) :: ier

      integer jer

      ier = 0

      this % permc_spec = 2 ! seems to work best

      this % nnz = 0
      this % size_ptr = rank+1
      this % size = size
      this % base = base
      this % col_counter = 0
      allocate(this%irow(this%size), stat=jer)
      if(jer /= 0 ) then
         ier = 9
         return
      end if
      allocate(this%values(this%size), stat=jer)
      if(jer /= 0 ) then
         ier = 10
         return
      end if
      allocate(this%jcol_ptr(this%size_ptr), stat=jer)
      if(jer /= 0 ) then
         ier = 11
         return
      end if
      this%irow = 0
      this%jcol_ptr = 0
      this%values = 0
      if(jer /=0 ) ier = 1
      
    end subroutine sparseR8_init
    
    subroutine sparseR8_free(this, ier)

      ! Destructor

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(out) :: ier

      integer jer

      ier = 0
      deallocate(this%irow, stat=jer)
      deallocate(this%values, stat=jer)
      deallocate(this%jcol_ptr, stat=jer)
      if(jer/=0) ier = 2
      
    end subroutine sparseR8_free

    subroutine sparseR8_copy(this, that, ier)

      ! Copy this into that. that should be unitialized.

      implicit none
      type(sparseR8_obj) :: this, that
      integer, intent(out) :: ier

      integer jer

      ier = 0
      that % nnz = this % nnz
      that % size_ptr = this % size_ptr
      that % size = this % size
      that % base = this % base
      that % col_counter = this % col_counter
      allocate(that%irow(that%size), stat=jer)
      if(jer /= 0 ) then
         ier = 9
         return
      end if
      allocate(that%values(that%size), stat=jer)
      if(jer /= 0 ) then
         ier = 10
         return
      end if
      allocate(that%jcol_ptr(that%size_ptr), stat=jer)
      if(jer /= 0 ) then
         ier = 11
         return
      end if
      that % irow = this%irow
      that % jcol_ptr = this%jcol_ptr
      that % values = this%values
      if(jer /=0 ) ier = 12
      
      
    end subroutine sparseR8_copy

    subroutine sparseR8_compare_shapes(this, that, ier)

      ! Compare two sparse matrices

      implicit none
      type(sparseR8_obj) :: this, that
      integer, intent(out) :: ier

      integer i

      ier = 0
      if(this%base /= that%base) then
         ier = 13
         return
      end if
      if(this%nnz /= that%nnz) then
         ier = 14
         return
      end if
      if(this%size_ptr /= that%size_ptr) then
         ier = 15
         return
      end if
      if(this%size /= that%size) then
         ier = 16
         return
      end if
      if(this%col_counter /= that%col_counter) then
         ier = 17
         return
      end if
      do i = 1, this%size_ptr
         if(this%jcol_ptr(i) /= that%jcol_ptr(i)) then
            ier = 18
            return 
         end if
      enddo
      do i = 1, this%size
         if(this%irow(i) /= that%irow(i)) then
            ier = 19
            return      
         end if
      enddo


    end subroutine sparseR8_compare_shapes

    subroutine sparseR8_set_next(this, row, newcol_flag, value, ier)

      ! Set next value. Must iterate down each column 
      ! running from left to right.
      !
    
      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: row 
      logical, intent(in) :: newcol_flag ! .TRUE. if new column, .FALSE. otherwise
      real(r8), intent(in) :: value 
      integer, intent(out) :: ier

      ier = 0
      this % nnz = this % nnz + 1
      if(this % nnz > this % size) then         
         ier = 3
         return
      endif
      this % irow(this%nnz) = row
      this % values(this%nnz) = value
      if(newcol_flag) then
         this % col_counter = this % col_counter + 1
         this % jcol_ptr(this % col_counter) = this%nnz - 1 + this%base
      endif
      this % jcol_ptr(this % col_counter+1) = this%nnz + this%base
      
    end subroutine sparseR8_set_next

    subroutine sparseR8_get_size(this, nrows, ncols, ier)

      ! Return no of rows and columns

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(out) :: nrows, ncols
      integer, intent(out) :: ier

      ier = 0
      nrows = maxval(this % irow)
      ncols = this % col_counter
    end subroutine sparseR8_get_size

    subroutine sparseR8_solve(this, rhs, ier)

      ! Solve matrix system
      
      implicit none
      type(sparseR8_obj) :: this
      real(r8), intent(inout) :: rhs(:) ! right-hand side vector, solution vector upon return
      integer, intent(out) :: ier

      integer n, jer
      integer :: handle(8) ! opaque handle

      ier = 0
      n = size(rhs)

      ! note: we pass here address (1) of vectors to force passing the 
      ! arguments by reference. 
      call dsupralu_new(handle, &
           & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, n, &
           & jer)
      call dsupralu_colperm(handle, this % permc_spec, jer)
      call dsupralu_lu(handle, jer)
      call dsupralu_solve(handle, rhs(1), jer)
      call dsupralu_del(handle, jer)

      if(jer/=0) ier = 8

    end subroutine sparseR8_solve

    subroutine sparseR8_det(this, res_mantissa, res_exponent, ier)

      ! Return the determinant of A in the form of 
      !
      ! res_mantissa * 2**res_exponent

      implicit none
      type(sparseR8_obj) :: this
      real(r8), intent(out) :: res_mantissa
      integer, intent(out) :: res_exponent
      integer, intent(out) :: ier
      
      integer :: handle(8) ! opaque handle
      integer :: n, jer

      ier = 0
      n = this % col_counter
      call dsupralu_new(handle, &
           & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, n, &
           & jer)
      call dsupralu_colperm(handle, this % permc_spec, jer)
      call dsupralu_lu(handle, jer)
      call dsupralu_determinant(handle, res_mantissa, res_exponent, jer)
      call dsupralu_del(handle, jer)
      if(jer/=0) ier = 20

    end subroutine sparseR8_det

    subroutine sparseR8_A_dot_x(this, x, res, ier)

      ! matrix . x => res

      implicit none
      type(sparseR8_obj) :: this
      real(r8), intent(in) :: x(:) ! vector
      real(r8), intent(out) :: res(:) ! result
      integer, intent(out) :: ier

      integer i, k, rank, j

      ier = 0
      res = 0
      rank = maxval(this % irow) + 1 - this%base

      
      do j = this%base+1, rank
         do k = this%jcol_ptr(j)+1-this%base, this%jcol_ptr(j+1)-this%base
            i = this%irow(k) + 1 - this%base
            res(i) = res(i) + this%values(k)*x(j)
         enddo
      enddo
      
    end subroutine sparseR8_A_dot_x

    subroutine sparseR8_save(this, filename, ier)

    ! Save state in netCDF file 'filename'

    use ezcdf
    implicit none
    type(sparseR8_obj) :: this
    character(*), intent(in) :: filename
    integer, intent(out) :: ier

    integer ncid, jer
    ier = 0

    call cdf_open(ncid, filename, 'w', jer)

    call cdf_define(ncid, 'version', (/len_trim(version),0,0/), 'CHAR', jer)
    call cdf_define(ncid, 'size', this%size, jer)
    call cdf_define(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_define(ncid, 'nnz', this%nnz, jer)
    call cdf_define(ncid, 'col_counter', this%col_counter, jer)
    call cdf_define(ncid, 'base', this%base, jer)
    call cdf_define(ncid, 'irow', this%irow(1:this%nnz), jer)
    call cdf_define(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_define(ncid, 'values', this%values(1:this%nnz), jer)

    call cdf_write(ncid, 'version', version, jer)
    call cdf_write(ncid, 'size', this%size, jer)
    call cdf_write(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_write(ncid, 'nnz', this%nnz, jer)
    call cdf_write(ncid, 'col_counter', this%col_counter, jer)
    call cdf_write(ncid, 'base', this%base, jer)
    call cdf_write(ncid, 'irow', this%irow(1:this%nnz), jer)
    call cdf_write(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_write(ncid, 'values', this%values(1:this%nnz), jer)

    call cdf_close(ncid, jer) 
    if(jer /= 0) ier = 4

    end subroutine sparseR8_save

    subroutine sparseR8_load(this, filename, ier)

      ! Load state from netCDF file 'filename'

    use ezcdf
    implicit none
    type(sparseR8_obj) :: this
    character(*), intent(in) :: filename
    integer, intent(out) :: ier

    integer ncid, jer
    ier = 0

    call cdf_open(ncid, filename, 'r', jer)

    call cdf_read(ncid, 'size', this%size, jer)
    call cdf_read(ncid, 'size_ptr', this%size_ptr, jer)
    call cdf_read(ncid, 'nnz', this%nnz, jer)
    call cdf_read(ncid, 'col_counter', this%col_counter, jer)
    call cdf_read(ncid, 'base', this%base, jer)
    allocate(this % irow(this%size), stat=jer)
    allocate(this % jcol_ptr(this%size_ptr), stat=jer)
    allocate(this % values(this%size), stat=jer)
    if(jer /= 0) then 
       ier = 1
       return
    endif
    call cdf_read(ncid, 'irow', this%irow, jer)
    call cdf_read(ncid, 'jcol_ptr', this%jcol_ptr, jer)
    call cdf_read(ncid, 'values', this%values, jer)

    call cdf_close(ncid, jer) 
    if(jer /= 0) ier = 5
      
    end subroutine sparseR8_load

    subroutine sparseR8_test(this, ier)

      ! Test unit

      implicit none
      type(sparseR8_obj) :: this, that, amat, bmat
      integer, intent(out) :: ier

      integer rank, size, base, i, nmax
      ! **not needed: eigen vector C16 only (dmc): real(r8) :: tol
      real(r8), allocatable :: rhs(:), x(:), res(:), y(:)
      real(r8) :: lambda, adet, bdet, adet_mantissa, bdet_mantissa
      integer :: adet_exponent, bdet_exponent
      real(r8) :: cum_error

      ier = 0
      cum_error = 0
      print *, 'testing sparseR8...', version

      base = 0 ! C-like
      rank = 5
      size = 10
      call sparseR8_init(this, rank, size, base, ier)
      ! matrix to store
      ! [ 0 2 x 7 x ]
      ! [ 1 3 x x x ]
      ! [ x x 4 x x ]
      ! [ x x 5 8 x ]
      ! [ x x 6 x 9 ]
      ! the result should be 
      ! irow = [0,1,0,1,2,3,4,0,3,4]
      ! jcol_ptr = [0,2,4,7,9]
      ! values = [0,1,2,3,4,5,6,7,8,9]
      print *, '...assembling'
      call sparseR8_set_next(this, 0, .TRUE., 0._r8, ier)
      call sparseR8_set_next(this, 1, .FALSE., 1._r8, ier)
      call sparseR8_set_next(this, 0, .TRUE., 2._r8, ier)
      call sparseR8_set_next(this, 1, .FALSE., 3._r8, ier)
      call sparseR8_set_next(this, 2, .TRUE., 4._r8, ier)
      call sparseR8_set_next(this, 3, .FALSE., 5._r8, ier)
      call sparseR8_set_next(this, 4, .FALSE., 6._r8, ier)
      call sparseR8_set_next(this, 0, .TRUE., 7._r8, ier)
      call sparseR8_set_next(this, 3, .FALSE., 8._r8, ier)
      call sparseR8_set_next(this, 4, .TRUE., 9._r8, ier)

      print *, '...saving'
      call sparseR8_save(this, 'sparseR8.nc', ier)
      call sparseR8_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,'...freeing'
      call sparseR8_free(this, ier)
      cum_error = cum_error + ier

      print *,'...loading'
      call sparseR8_load(this, 'sparseR8.nc', ier)
      call sparseR8_error(this, 6, ier)
      cum_error = cum_error + ier

      print *, '...saving'
      call sparseR8_save(this, 'sparseR8_2.nc', ier)
      call sparseR8_error(this, 6, ier)
      cum_error = cum_error + ier

      allocate(rhs(rank), x(rank), res(rank))
      rhs = (/ (i, i=1,rank) /)
      x = rhs
      print *, '...solving'
      call sparseR8_solve(this, x, ier)      
      cum_error = cum_error + ier
      call sparseR8_A_dot_x(this, x, res, ier)
      cum_error = cum_error + ier
      print *,'error = ', sqrt(abs(sum((res - rhs)**2)/rank))
      cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))

      call sparseR8_copy(this, that, ier)
      call sparseR8_error(this, 6, ier)      
      cum_error = cum_error + ier

      that % values = 2 * this % values

      call sparseR8_free(this, ier)
      cum_error = cum_error + ier
      call sparseR8_free(that, ier)
      cum_error = cum_error + ier

!!$>> amat=[1. -1 0; -1 2 3; 0 1 1.];
!!$>> bmat=[1 0.5 0; 0.5 1 0.5; 0 0.5 1];
!!$>> det(amat)
!!$
!!$ans =
!!$
!!$    -2
!!$
!!$>> det(bmat)
!!$
!!$ans =
!!$
!!$    0.5000


      call sparseR8_init(amat, 3, 7, 0, ier)
      call sparseR8_set_next(amat, 0, .TRUE.,  1._r8, ier)
      call sparseR8_set_next(amat, 1, .FALSE.,-1._r8, ier)
      call sparseR8_set_next(amat, 0, .TRUE., -1._r8, ier)
      call sparseR8_set_next(amat, 1, .FALSE., 2._r8, ier)
      call sparseR8_set_next(amat, 2, .FALSE., 1._r8, ier)
      call sparseR8_set_next(amat, 1, .TRUE.,  3._r8, ier)
      call sparseR8_set_next(amat, 2, .FALSE., 1._r8, ier)
      cum_error = cum_error + ier

      call sparseR8_init(bmat, 3, 7, 0, ier)
      call sparseR8_set_next(bmat, 0, .TRUE.,  1._r8, ier)
      call sparseR8_set_next(bmat, 1, .FALSE., .5_r8, ier)
      call sparseR8_set_next(bmat, 0, .TRUE.,  .5_r8, ier)
      call sparseR8_set_next(bmat, 1, .FALSE., 1._r8, ier)
      call sparseR8_set_next(bmat, 2, .FALSE., .5_r8, ier)
      call sparseR8_set_next(bmat, 1, .TRUE.,  .5_r8, ier)
      call sparseR8_set_next(bmat, 2, .FALSE., 1._r8, ier)
      cum_error = cum_error + ier

      amat % permc_spec = 2
      call sparseR8_det(amat, adet_mantissa, adet_exponent, ier)
      call sparseR8_det(bmat, bdet_mantissa, bdet_exponent, ier)
      adet = adet_mantissa * 2._r8**adet_exponent
      bdet = bdet_mantissa * 2._r8**bdet_exponent
      print *,'det A = ',adet,' det B = ', bdet
      cum_error = cum_error + abs(adet - real(-2,r8))
      cum_error = cum_error + abs(bdet - 0.5_r8)

      deallocate(rhs, x, res)
      call sparseR8_free(amat, ier)
      call sparseR8_free(bmat, ier)

      print *,'***********************************************************'
      print *,'CUMULATIVE ERROR = ', cum_error
      if(cum_error > 1.e-10_r8) then
         print *,' **TEST FAILED**'
      else
         print *,' TEST SUCCEEDED '
      endif
      print *,'***********************************************************'

    end subroutine sparseR8_test

    subroutine sparseR8_error(this, nunit, ier)
      
      ! Error handler
      
      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: nunit ! output channel
      integer, intent(in) :: ier
      
      character(*), parameter :: header = 'SparseR8::'

    select case(ier)
       case(1)
          write(nunit, *) header//'ERROR while initializing'
       case(2)
          write(nunit, *) header//'ERROR while deallocating'
       case(3)
          write(nunit, *) &
               & header//'ERROR counter exceeded declared size ', this%size,' rank=', this%size_ptr-1
       case(4)
          write(nunit, *) header//'ERROR while saving'
       case(5)
          write(nunit, *) header//'ERROR while loading'
       case(6)
          write(nunit, *) header//'ERROR occurred in test unit'
       case(7)
          write(nunit, *) header//'ERROR method not implemented'
       case(8)
          write(nunit, *) header//'ERROR occurred in solve'
       case(9)
          write(nunit, *) header//'ERROR occurred when allocating "irow"'
       case(10)
          write(nunit, *) header//'ERROR occurred when allocating "values"'
       case(11)
          write(nunit, *) header//'ERROR occurred when allocating "jcol_ptr"'
       case(12)
          write(nunit, *) header//'ERROR occurred when copying'
       case(13)
          write(nunit, *) header//'WARNING "base" mismatch'
       case(14)
          write(nunit, *) header//'WARNING "nnz" mismatch'
       case(15)
          write(nunit, *) header//'WARNING "size_ptr" mismatch'
       case(16)
          write(nunit, *) header//'WARNING "size" mismatch'
       case(17)
          write(nunit, *) header//'WARNING "col_counter" mismatch'
       case(18)
          write(nunit, *) header//'WARNING "jcol_ptr" array differ'
       case(19)
          write(nunit, *) header//'WARNING "irow" array differ'
       case(20)
          write(nunit, *) header//'ERROR occurred  in det'
       
       case default
    end select    
      
      
    end subroutine sparseR8_error

end module supralu_mod
