module supralu_mod

  !  modified dmc Jan 28 2004:
  !
  !  imbed C object handles in f90 object; add "state tracking" to 
  !  objects.  If the f90 object is initialized but has no associated
  !  C object, then, its handle is ZERO.
  !
  !  f90 objects need to be "initialized" to have known state; if an
  !  object containing data is re-initialized, the contained data may
  !  be lost but still resident in memory (i.e. a memory leak).
  !
  !  see "memtrace" utility to help with detection of potential memory
  !  leaks.
  !
  !  A note on state.  state is not preserved across copy or save/load
  !  operations.  Each object has its own state for tracking its own, 
  !  independent LU factorization.  There is an array "ref_count" which
  !  tracks references to the C objects containing these factorizations,
  !  but at this time ref_count elements only take on values of 0 or 1
  !  according as the corresponding C object handle is in use yet, or not.
  !
  !    So:  if A and B are sparse<xx>_objects and A is factored, setting
  !         B=A copies A's data, but not its factorization.  If Bx=RHS
  !         is solved, B will be (re)factored.  It would be more efficient
  !         if the factorization of A had been copied somehow, sparing the
  !         need to recompute it, but, this capability does not (yet) exist.

  !  Also: interface statements added, to preserve the old interface while
  !        supporting the new object initialization requirements implied by
  !        the introduction of state tracking.

  !  Also: "base" is re-interpreted.  Internally the row/col indices
  !        use C-style 0-based indexing *always*; "base" is only used
  !        to determine the interpretation of row/col indices passed 
  !        in by callers e.g. in <obj>_set_next methods.

  implicit none
  SAVE          ! for "ntrace" and "messages" debug flags only

  ! Column-compressed-storage based sparse matrix container

  integer, parameter, private :: r8 = selected_real_kind(12,100)
  character(*), parameter, private :: version = &
       & '$Id: supralu_mod.f90,v 1.7 2004-02-09 05:04:16 xshare Exp $'
  
  type sparseC16_obj
     integer, pointer :: irow(:)        ! row indices for each column
     integer, pointer :: jcol_ptr(:)    ! pointer into irow for each column
     complex(r8), pointer :: values(:)  ! values corresponding to irow elements
     integer :: size, size_ptr, nnz, col_counter, row_rank
     integer :: base       ! =0 (C-style indexing) or =1 (Fortran-style)

     ! dmc added Jan 28 2004
     integer :: guard      ! =123456789 if object has been initialized
     integer :: nstate     ! state code:
     ! -1 = f90 object initialized but not allocated
     !  0 = no associated C object
     !  1 = C object has been created
     !  2 = column permutation has been calculated
     !  3 = LU factorization has been calculated

     integer :: handle(2)  ! handle (address) for C object

     ! 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(:)        ! row indices for each column
     integer, pointer :: jcol_ptr(:)    ! pointer into irow for each column
     real(r8), pointer :: values(:)     ! values corresponding to irow elements
     integer :: size, size_ptr, nnz, col_counter, row_rank
     integer :: base       ! =0 (C-style indexing) or =1 (Fortran-style)

     ! dmc added Jan 28 2004
     integer :: guard      ! =123456789 if object has been initialized
     integer :: nstate     ! state code:
     ! -1 = f90 object initialized but not allocated
     !  0 = no associated C object
     !  1 = C object has been created
     !  2 = column permutation has been calculated
     !  3 = LU factorization has been calculated

     integer :: handle(2)  ! handle (address) for C object

     ! 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

  !-------------------------------
  interface sparseC16_init
     module procedure   sparseC16_init, sparseC16_init_alloc
  end interface

  interface sparseR8_init
     module procedure   sparseR8_init, sparseR8_init_alloc
  end interface

  interface sparseC16_set_next
     module procedure   sparseC16_set_next, sparseC16_set_next_col
  end interface

  interface sparseR8_set_next
     module procedure   sparseR8_set_next, sparseR8_set_next_col
  end interface

  !-------------------------------
  ! SAVEd data items in module: C object handles and reference counts;
  !   expandable arrays

  integer, private :: ntrace = 0   ! if non-zero: LUN for mem-trace output
  integer, private :: messages = 1 ! =0: no SuperLU messages; =1: yes

  !-------------------------------
  contains

!==============================================================================
! user accessible utility:  (de)activate memory trace
! (use this to detect memory leaks)
! supralu writes on the passed LUN ascii messages marking the following events:
!   --fortran object allocation
!   --fortran object deallocation
!   --C object allocation
!   --C object deallocation
! there should be a deallocation for each allocation; else a memory
! leak could be present!
!

    subroutine supralu_memtrace(lun)

      implicit NONE
      integer, intent(in) :: lun   ! Fortran LUN of open file on which to write
                                   ! trace messages, or, 0 to disable feature.

      ! it is the caller's responsibility to make sure LUN is valid...

      if((ntrace.ne.0).and.(lun.ne.ntrace)) then
         write(ntrace, &
              '(" -> supralu memtrace terminated on unit ",i5,".")') ntrace
      else if(ntrace.ne.0) then
         write(ntrace, &
              '(" -> supralu_memtrace call (unit ",i5," use continues).")') &
              ntrace
      endif

      ntrace = lun

      if(ntrace.ne.0) then
         write(ntrace, &
              '(" -> supralu memtrace initiated on unit ",i5,".")') ntrace
      endif

    end subroutine supralu_memtrace

    !-------------------------------------------------

    subroutine supralu_msgs(imsgs)
      implicit NONE
      logical, intent(in) :: imsgs

      if(imsgs) then
         messages = 1  ! enable SuperLU messages
      else
         messages = 0  ! disable SuperLU messages
      endif

    end subroutine supralu_msgs

!==============================================================================
! complex*16

    subroutine sparseC16_init(this)

      !  most basic initialization of sparseC16_obj -- put pointers in
      !  defined NULL state.

      implicit none
      type(sparseC16_obj) :: this

      this%guard = 123456789
      nullify(this%irow, this%jcol_ptr, this%values)
      this%nstate = -1
      this%handle = 0
      this % permc_spec = 3 ! seems to work best

    end subroutine sparseC16_init

    subroutine sparseC16_icheck(this,ier)

      !  check this%guard -- return error code if <> 123456789, i.e.
      !  if _init routine was never called.

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

      if(this%guard.ne.123456789) then
         ier=21  ! uninitialized
      else
         ier=0
      endif

    end subroutine sparseC16_icheck

    subroutine sparseC16_init_alloc(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

      call sparseC16_init(this)
      call sparseC16_alloc(this, rank, size, base, ier)

    end subroutine sparseC16_init_alloc

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

      !  allocate memory for sparse matrix object.  Object must have
      !  been initialized.  If memory was already allocated, it is
      !  freed first.

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: rank  ! rank (n) of sparse matrix
      integer, intent(in) :: size  ! no. of non-zero elements << n**2
      integer, intent(in) :: base  ! =0: C-indexing; =1: Fortran-indexing
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer

      call sparseC16_free(this,ier)
      if(ier.ne.0) return

      this % nnz = 0
      this % size_ptr = rank+1
      this % size = size
      this % base = base
      this % col_counter = 0
      this % row_rank = 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

      this%handle = 0
      this%nstate = 0

      if(ntrace.ne.0) then
         write(ntrace, &
              '(" F90 C16 object allocated: rank=",i5," size=",i10,".")') &
              rank, size
      endif
      
    end subroutine sparseC16_alloc
    
    subroutine sparseC16_free(this, ier)

      ! Destructor -- deallocate memory associated with object
      !  this includes associated C object memory (if any).

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer,jjer,icount

      call sparseC16_icheck(this, ier)
      if(ier.ne.0) return   ! ier set if object was never initialized.

      if(this%nstate.gt.0) then
         !  there is an associated C object
         this%nstate = 0
         call zsupralu_del(this%handle(1), jer)
         if(jer/=0) ier = 8
         if(ntrace.ne.0) then
            write(ntrace, &
                 '(" C16 C objected deleted: rank=",i5," size=",i10)') &
                 this%size_ptr-1, this%size
         endif
         this%handle = 0
      endif

      jjer=0

      icount=0
      if(associated(this%irow)) then
         icount=icount+1
         deallocate(this%irow, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(associated(this%values)) then
         icount=icount+1
         deallocate(this%values, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(associated(this%jcol_ptr)) then
         icount=icount+1
         deallocate(this%jcol_ptr, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(jjer/=0) ier = max(2,ier)

      this%nstate=-1

      if(icount.eq.3) then
         if(ntrace.ne.0) then
            write(ntrace, &
                 '(" F90 C16 objected deleted: rank=",i5," size=",i10)') &
                 this%size_ptr-1, this%size
         endif
      endif
      
    end subroutine sparseC16_free

    subroutine sparseC16_get_permc(this, ipermc, ier)

      implicit NONE
      type(sparseC16_obj) :: this
      integer, intent(out) :: ipermc  ! permutation control (returned)
      integer, intent(out) :: ier  !  status code; 0=OK

      ipermc=-1

      call sparseC16_icheck(this, ier)
      if(ier.ne.0) return

      ipermc = this%permc_spec

    end subroutine sparseC16_get_permc

    subroutine sparseC16_set_permc(this, ipermc, ier)

      implicit NONE
      type(sparseC16_obj) :: this
      integer, intent(in) :: ipermc  ! permutation control (set)
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseC16_icheck(this, ier)
      if(ier.ne.0) return

      this%permc_spec = ipermc

    end subroutine sparseC16_set_permc

    subroutine sparseC16_copy(this, that, ier)

      ! Copy this into that. this should contain data; 
      ! that should be initialized.

      implicit none
      type(sparseC16_obj) :: this, that
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseC16_icheck(this, ier)
      if(ier.ne.0) then
         ier=22  ! "from" object not initialized.
         return
      endif

      call sparseC16_icheck(that, ier)
      if(ier.ne.0) then
         ier=23  ! "to" object not initialized.
         return
      endif

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.  data required for copy.
         return
      endif

      !  free memory currently used by "that"; allocate matching size arrays
      call sparseC16_alloc(that, this%size_ptr-1, this%size, this%base, ier)

      that % nnz = this % nnz
      that % col_counter = this % col_counter
      that % row_rank = this % row_rank

      !  data array copies:
      that % irow = this%irow
      that % jcol_ptr = this%jcol_ptr
      that % values = this%values

      that % permc_spec = this%permc_spec

      that % nstate = 0
      that % handle = 0  ! *note* C object not copied ***

    end subroutine sparseC16_copy

    subroutine sparseC16_compare_shapes(this, that, ier)

      ! Compare two sparse matrices
      ! status code is set if shapes do not match, or if there is 
      ! some other error, e.g. "this" or "that" not initialized.

      implicit none
      type(sparseC16_obj) :: this, that
      integer, intent(out) :: ier  !  status code; 0 = SHAPES MATCH

      integer i

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      call sparseC16_icheck(that, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      if(that%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      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_update_element(this, irow, jcol, value, ier)

      ! update specified element of sparse matrix
      ! if matrix has been factored, only an existing element can be
      ! updated; if the matrix is new, new elements may be added, but
      ! *only* in increasing order of row index within increasing order
      ! of column index.

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: irow      ! element row index
      integer, intent(in) :: jcol      ! element column index
      complex(r8), intent(in) :: value ! element value
      integer, intent(out) :: ier  !  status code; 0=OK

      integer :: i,ii,j,j1,imatch
      logical newcol_flag

      call sparseC16_dmark(this, ier)   ! verify initialization; mark update
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object not allocated
         return
      endif

      i = irow - this%base   ! i: 0,1,...,(N-1)
      j = jcol - this%base   ! j: 0,1,...,(N-1)
      j1 = j+1

      !  try for update first...

      imatch=0
      if( j1.gt.0 .and. (j1 .le. this%col_counter) ) then
         do ii = this%jcol_ptr(j1)+1,this%jcol_ptr(j1+1)
            if(this%irow(ii).eq.i) then
               imatch=ii
               exit
            endif
         enddo
      endif

      if(imatch.gt.0) then
         this%values(ii) = value
      else
         if(this%nstate.eq.0) then
            ! new element definition still possible...
            if(j1.eq.this%col_counter) then
               newcol_flag=.FALSE.
               call sparseC16_set_next(this, irow, newcol_flag, value, ier)
            else if(j1.eq.this%col_counter+1) then
               newcol_flag=.TRUE.
               call sparseC16_set_next(this, irow, newcol_flag, value, ier)
            else
               ier=31
            endif
         else
            ier=31
         endif
      endif

    end subroutine sparseC16_update_element

    subroutine sparseC16_update_column(this, nrow, irows, vals, jcol, ier)
      ! update elements in a column.

      ! if this is an update to elements of an existing column in a matrix
      ! that has already been defined, then, the rows specified must match
      ! exactly the sparsity pattern in the matrix as it was originally 
      ! defined.

      ! if the matrix is new, then, columns must be presented in ascending
      ! order, i.e. moving from left to right.

      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: nrow        ! no. of rows
      integer, intent(in) :: irows(nrow) ! row indices
      complex(r8), intent(in) :: vals(nrow)  ! corresponding element values
      integer, intent(in) :: jcol        ! column index
      integer, intent(out) :: ier  !  status code; 0=OK

      integer j,j1,inum,ii,imatch,iadr

      call sparseC16_dmark(this, ier)   ! verify initialization; mark update
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object not allocated.
         return
      endif

      j=jcol-this%base    ! get C (0-based) column index
      j1=j+1

      !  check for update
      if(j1.le.this%col_counter) then
         !  column already defined; enforce matching row elements
         inum = this%jcol_ptr(j1+1) - this%jcol_ptr(j1)
         if(inum.ne.nrow) then
            ier=32
         else
            imatch=1
            do ii=1,nrow
               iadr = this%jcol_ptr(j1)+ii
               if(irows(ii)-this%base .ne. this%irow(iadr)) then
                  imatch=0
                  exit
               endif
            enddo
            if(imatch.eq.0) then
               ier=32
            else
               iadr = this%jcol_ptr(j1)+1
               this%values(iadr:iadr+nrow-1)=vals(1:nrow)
            endif
         endif
      else if(j1.ne.this%col_counter+1) then
         !  new columns must be presented in ascending order
         ier=33
      else
         !  add new column
         call sparseC16_set_next_col(this, nrow, irows, vals, ier)
      endif

    end subroutine sparseC16_update_column

    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         ! element row index
      logical, intent(in) :: newcol_flag ! .TRUE. if new column, else .FALSE.
      complex(r8), intent(in) :: value   ! element value
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.gt.0) then
         ier=30  ! cannot add elements -- matrix already LU factorized.
         return
      endif

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      if(newcol_flag) then
         this % col_counter = this % col_counter + 1
         if(this%col_counter.ge.this%size_ptr) then
            ier=1
            return
         endif
         this % jcol_ptr(this % col_counter) = this%nnz
      endif

      this % nnz = this % nnz + 1
      if(this % nnz > this % size) then         
         ier = 3
         return
      endif
      this % irow(this%nnz) = row - this%base

      if(.not.newcol_flag) then
         if(this%col_counter.eq.0) then
            ier=31   ! 1st column never started
         else if(this%irow(this%nnz).le.this%irow(this%nnz-1)) then
            ier=31   ! rows not in ascending order w/in a column
         endif
      endif

      this % row_rank = max( this%row_rank, row - this%base + 1)
      this % values(this%nnz) = value
      this % jcol_ptr(this % col_counter+1) = this%nnz
      
    end subroutine sparseC16_set_next

    subroutine sparseC16_set_next_col(this, nrow, rowvec, valvec, ier)

      ! Set next column of values. Must iterate over columns
      ! running from left to right.
    
      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: nrow          ! no. of non-zero row elements
      integer, intent(in) :: rowvec(nrow)  ! element indices (ascending order)
      complex(r8), intent(in) :: valvec(nrow) ! element values
      integer, intent(out) :: ier  !  status code; 0=OK

      integer :: istart,i

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.gt.0) then
         ier=30  ! cannot add elements -- matrix already LU factorized.
         return
      endif

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      this % col_counter = this % col_counter + 1
      if(this%col_counter.ge.this%size_ptr) then
         ier=1
         return
      endif
      this % jcol_ptr(this % col_counter) = this%nnz

      istart = this%nnz + 1
      this % nnz = this % nnz + nrow
      if(this % nnz > this % size) then         
         ier = 3
         return
      endif

      this % irow(istart:this%nnz) = rowvec - this%base
      do i=istart+1,this%nnz
         if( this%irow(i).le.this%irow(i-1) ) then
            ier=31  ! rows not given in ascending order
         endif
      enddo

      this % row_rank = max( this%row_rank, maxval(rowvec) - this%base + 1)

      this % values(istart:this%nnz) = valvec

      this % jcol_ptr(this % col_counter+1) = this%nnz
      
    end subroutine sparseC16_set_next_col

    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

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      nrows = this % row_rank
      ncols = this % col_counter

    end subroutine sparseC16_get_size

    subroutine sparseC16_dmark(this, ier)

      !  mark that data has changed-- LU factorization needs to be 
      !  recomputed

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

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      this%nstate = min(2, this%nstate)

    end subroutine sparseC16_dmark

    subroutine sparseC16_solve(this, rhs, ier)

      ! Solve matrix system  A*x=b
      ! "this" is A, "rhs" is b on input, x on output.
      
      implicit none
      type(sparseC16_obj) :: this
      complex(r8), intent(inout) :: rhs(:) ! right-hand side vector;
                                           ! solution vector upon return
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer,n

      call sparseC16_factor(this, ier)
      if(ier.ne.0) return

      n=size(rhs)
      if(n.ne.this%row_rank) then
         ier=29  ! length of RHS vector must match rank of matrix
         return
      endif

      call zsupralu_solve(this%handle(1), rhs(1), jer)

      if(jer/=0) ier = 8

    end subroutine sparseC16_solve
 
    subroutine sparseC16_factor(this,ier)

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

      integer jer

      call sparseC16_icheck(this, ier)
      if(ier.ne.0) return   ! ier set if object was never initialized.

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      !  LU factor a matrix -- but do not do more work than necessary

      if(this%row_rank.ne.this%col_counter) then
         ier=28
         return
      endif

      if(this%nstate.eq.0) then
         ! create C object; fetch C object handle
         call zsupralu_new( this%handle(1), &
              & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, &
              & this%row_rank, &
              & jer)

         if(jer.ne.0) then
            this%handle = 0
            ier = 26
         else
            this%nstate = 1  ! C object successfully created.
            call zsupralu_msgs(this%handle(1), messages)
            if(ntrace.ne.0) then
               write(ntrace, &
                    '(" C16 C objected created: rank=",i5," size=",i10)') &
                    this%size_ptr-1, this%size
            endif
         endif
      endif
      if(ier.ne.0) return

      if(this%nstate.eq.1) then
         ! compute column permuation

         call zsupralu_colperm(this%handle(1), this % permc_spec, jer)
         if(jer.ne.0) then
            ier=27
         else
            this%nstate = 2  ! permutations obtained.
         endif
      endif

      if(this%nstate.eq.2) then
         ! compute LU factorization

         call zsupralu_lu(this%handle(1), jer)
         if(jer.ne.0) then
            ier=28
         else
            this%nstate = 3  ! LU factorization obtained.
         endif
      endif

    end subroutine sparseC16_factor

    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  !  status code; 0=OK

      call sparseC16_factor(this, ier)
      if(ier.ne.0) return

      call zsupralu_determinant(this%handle(1), res_mantissa, res_exponent, ier)
      if(ier/=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

      call sparseC16_compare_shapes(Amat, Bmat, ier)
      if(ier.ne.0) return

      call sparseC16_init(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_dmark(Cmat, ier)  ! values, changed!
         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_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  !  status code; 0=OK

      integer i, k, rank, j

      ier = 0
      res = 0

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

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

    subroutine sparseC16_save(this, filename, ier)

    ! Save object data in netCDF file 'filename'

      use ezcdf
      implicit none
      type(sparseC16_obj) :: this
      character(*), intent(in) :: filename
      integer, intent(out) :: ier  !  status code; 0=OK

      integer ncid, jer

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! no data
         return
      endif

      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, 'row_rank', this%row_rank, 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_define(ncid, 'permc_spec', this%permc_spec, 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, 'row_rank', this%row_rank, 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_write(ncid, 'permc_spec', this%permc_spec, jer)

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

    end subroutine sparseC16_save

    subroutine sparseC16_load(this, filename, ier)

      ! Load data from netCDF file 'filename'
      ! Memory associated with existing data is deallocated first.

      use ezcdf
      implicit none
      type(sparseC16_obj) :: this
      character(*), intent(in) :: filename
      integer, intent(out) :: ier  !  status code; 0=OK

      integer ncid, jer

      integer isize,irank,ibase

      call sparseC16_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

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

      call cdf_read(ncid, 'size', isize, jer)
      call cdf_read(ncid, 'size_ptr', irank, jer); irank = irank-1
      call cdf_read(ncid, 'base', ibase, jer)
      if(jer /= 0) then
         ier = 5
         call cdf_close(ncid, jer)
         return
      endif

      !  allocate space.  If object already has allocated space it is freed.
      call sparseC16_alloc(this, irank, isize, ibase, ier)
      if(ier.ne.0) then
         call cdf_close(ncid,jer)
         return
      endif

      call cdf_read(ncid, 'nnz', this%nnz, jer)
      call cdf_read(ncid, 'col_counter', this%col_counter, jer)
      call cdf_read(ncid, 'row_rank', this%row_rank, jer)

      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) elems(10)
      complex(r8) :: lambda, adet, bdet, adet_mantissa, bdet_mantissa
      integer :: adet_exponent, bdet_exponent,irows(5)
      real(r8) :: cum_error

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

      base = 0 ! C-like
      !!! base = 1 ! fortran-like  (affects set/update calls below)
      rank = 5
      size = 10
      call sparseC16_init(this)
      call sparseC16_init(that)
      call sparseC16_alloc(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]

      do i=1,10
         if(i.le.5) irows(i)=i-1+base
         elems(i) = cmplx(1.0_r8*(i-1), 0.0_r8, r8)
      enddo

      print *, '...assembling'
      call sparseC16_set_next(this, 0, .TRUE., cmplx(0., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 1, .FALSE., cmplx(1., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 0, .TRUE., cmplx(2., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 1, .FALSE., cmplx(3., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 2, .TRUE., cmplx(4., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 3, .FALSE., cmplx(5., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 4, .FALSE., cmplx(6., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 0, .TRUE., cmplx(7., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 3, .FALSE., cmplx(8., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_set_next(this, 4, .TRUE., cmplx(9., 0., r8), ier); cum_error = cum_error + ier

      call sparseC16_update_element(this, 0, 0, cmplx(0., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 1, 0, cmplx(1., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 0, 1, cmplx(2., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 1, 1, cmplx(3., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 2, 2, cmplx(4., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 3, 2, cmplx(5., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 4, 2, cmplx(6., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 0, 3, cmplx(7., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 3, 3, cmplx(8., 0., r8), ier); cum_error = cum_error + ier
      call sparseC16_update_element(this, 4, 4, cmplx(9., 0., r8), ier); cum_error = cum_error + ier

      call sparseC16_update_column(this, 2, (/0, 1/), elems(1:2), 0, ier); cum_error = cum_error + ier
      call sparseC16_update_column(this, 2, (/0, 1/), elems(3:4), 1, ier); cum_error = cum_error + ier
      call sparseC16_update_column(this, 3, (/2, 3, 4/), elems(5:7), 2, ier); cum_error = cum_error + ier
      call sparseC16_update_column(this, 2, (/0, 3/), elems(8:9), 3, ier); cum_error = cum_error + ier
      call sparseC16_update_column(this, 1, irows(5:5), elems(10:10), 4, ier); cum_error = cum_error + ier

      !  uncomment these ( and comment the above set/update calls) if base=1:

      ! call sparseC16_update_column(this, 2, (/1, 2/), elems(1:2), 1, ier); cum_error = cum_error + ier
      ! call sparseC16_update_column(this, 2, (/1, 2/), elems(3:4), 2, ier); cum_error = cum_error + ier
      ! call sparseC16_update_column(this, 3, (/3, 4, 5/), elems(5:7), 3, ier); cum_error = cum_error + ier
      ! call sparseC16_update_column(this, 2, (/1, 4/), elems(8:9), 4, ier); cum_error = cum_error + ier
      ! call sparseC16_update_column(this, 1, irows(5:5), elems(10:10), 5, ier); cum_error = cum_error + 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), y(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))

      y=x

      ! redo problem with fortran-style indexing; compare result
      call sparseC16_free(this, ier)

      base = 1  ! fortran style
      call sparseC16_alloc(this, rank, size, base, ier)

      call sparseC16_set_next(this, 1, .TRUE., cmplx(0., 0., r8), ier)
      call sparseC16_set_next(this, 2, .FALSE., cmplx(1., 0., r8), ier)
      call sparseC16_set_next(this, 1, .TRUE., cmplx(2., 0., r8), ier)
      call sparseC16_set_next(this, 2, .FALSE., cmplx(3., 0., r8), ier)
      call sparseC16_set_next(this, 3, .TRUE., cmplx(4., 0., r8), ier)
      call sparseC16_set_next(this, 4, .FALSE., cmplx(5., 0., r8), ier)
      call sparseC16_set_next(this, 5, .FALSE., cmplx(6., 0., r8), ier)
      call sparseC16_set_next(this, 1, .TRUE., cmplx(7., 0., r8), ier)
      call sparseC16_set_next(this, 4, .FALSE., cmplx(8., 0., r8), ier)
      call sparseC16_set_next(this, 5, .TRUE., cmplx(9., 0., r8), ier)

      x = rhs
      call sparseC16_solve(this, x, ier)
      call sparseC16_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,' fortran/C indexing differnce: ',sqrt(abs(sum((x - y)**2)/rank))
      cum_error = cum_error + sqrt(abs(sum((x - y)**2)/rank))

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

      print *,'...solve for different RHS vectors'
      ! re-use LU decomposition
      do i = 1, 4
         rhs = x ! copy
         call sparseC16_solve(that, x, ier)
         call sparseC16_error(that, 6, ier)
         cum_error = cum_error + ier
         call sparseC16_A_dot_x(that, x, res, ier)
         cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))
      enddo
      print *,' cumulative error: ',cum_error

      print *,'...solve for different matrices that share the same sparsity'
      ! re-use permutation matrices
      do i = 1, 4
         ! reset the values
         that % values = i * that % values
         call sparseC16_dmark(that, ier)
         rhs = x ! copy
         call sparseC16_solve(that, x, ier)
         call sparseC16_error(that, 6, ier)
         cum_error = cum_error + ier
         call sparseC16_A_dot_x(that, x, res, ier)
         cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))         
      enddo
      print *,' cumulative error: ',cum_error

      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
      call sparseC16_dmark(that, ier)

      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 *,'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)
      call sparseC16_alloc(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)
      call sparseC16_alloc(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

      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))

      deallocate(y)
      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 *,'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 *,'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 *,'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 -- write message 
      
      implicit none
      type(sparseC16_obj) :: this
      integer, intent(in) :: nunit ! output channel (Fortran LUN)
      integer, intent(in) :: ier  !  status code  **INPUT**
      
      character(*), parameter :: header = 'SparseC16::'

    select case(ier)
       case(1)
          write(nunit, *) &
               & header//'ERROR: column counter exceeded declared rank: ', this%size_ptr-1
       case(2)
          write(nunit, *) header//'ERROR while deallocating'
       case(3)
          write(nunit, *) &
               & header//'ERROR: element counter exceeded declared size: ', this%size
       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(21)
          write(nunit, *) header//'ERROR: object used prior to initialization.'
       case(22)
          write(nunit, *) header//'ERROR: "from" object not initialized.'
       case(23)
          write(nunit, *) header//'ERROR: "to" object not initialized.'
       case(24)
          write(nunit, *) header//'ERROR: object not allocated; no data.'
       case(25)
          write(nunit, *) header//'ERROR: SuperLU (C) object creation failed.'
       case(26)
          write(nunit, *) header//'ERROR: SuperLU error (column permutation).'
       case(27)
          write(nunit, *) header//'ERROR: SuperLU error (LU factorization).'
       case(28)
          write(nunit, *) header//'ERROR: row rank not equal to column rank:'
          write(nunit, *) '  row_rank = ',this%row_rank
          write(nunit, *) '  col_rank = ',this%col_counter
       case(29)
          write(nunit, *) header//'ERROR: RHS vector size .ne. matrix rank:'
          write(nunit, *) '  matrix rank is: ',this%row_rank
       case(30)
          write(nunit, *) &
               header//'ERROR: attempt to add elements after LU factorization.'
       case(31)
          write(nunit, *) &
               header//'ERROR: element definition out of order.'
       case(32)
          write(nunit, *) &
               header//'ERROR: row element mismatch in column update.'
       case(33)
          write(nunit, *) &
               header//'ERROR: column definition out of order.'

       case(999)
          write(nunit, *) header//'ERROR -- handle array allocation failure.'

       case(0)
          continue
       
       case default
          write(nunit, *) header//'ERROR (unspecified) ier = ',ier

    end select    
      
    end subroutine sparseC16_error
    
!==============================================================================
! real*8

    subroutine sparseR8_init(this)

      !  most basic initialization of sparseR8_obj -- put pointers in
      !  defined NULL state.

      implicit none
      type(sparseR8_obj) :: this

      this%guard = 123456789
      nullify(this%irow, this%jcol_ptr, this%values)
      this%nstate = -1
      this%handle = 0
      this % permc_spec = 3 ! seems to work best

    end subroutine sparseR8_init

    subroutine sparseR8_icheck(this,ier)

      !  check this%guard -- return error code if <> 123456789, i.e.
      !  if _init routine was never called.

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

      if(this%guard.ne.123456789) then
         ier=21  ! uninitialized
      else
         ier=0
      endif

    end subroutine sparseR8_icheck

    subroutine sparseR8_init_alloc(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

      call sparseR8_init(this)
      call sparseR8_alloc(this, rank, size, base, ier)

    end subroutine sparseR8_init_alloc

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

      !  allocate memory for sparse matrix object.  Object must have
      !  been initialized.  If memory was already allocated, it is
      !  freed first.

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: rank  ! rank (n) of sparse matrix
      integer, intent(in) :: size  ! no. of non-zero elements << n**2
      integer, intent(in) :: base  ! =0: C-indexing; =1: Fortran-indexing
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer

      call sparseR8_free(this,ier)
      if(ier.ne.0) return

      this % nnz = 0
      this % size_ptr = rank+1
      this % size = size
      this % base = base
      this % col_counter = 0
      this % row_rank = 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

      this%handle = 0
      this%nstate = 0

      if(ntrace.ne.0) then
         write(ntrace, &
              '(" F90 R8 object allocated: rank=",i5," size=",i10,".")') &
              rank, size
      endif
      
    end subroutine sparseR8_alloc
    
    subroutine sparseR8_free(this, ier)

      ! Destructor  -- deallocate memory associated with object
      !  this includes associated C object memory (if any).

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer,jjer,icount

      call sparseR8_icheck(this, ier)
      if(ier.ne.0) return   ! ier set if object was never initialized.

      if(this%nstate.gt.0) then
         !  there is an associated C object
         this%nstate = 0
         call dsupralu_del(this%handle(1), jer)
         if(jer/=0) ier = 8
         if(ntrace.ne.0) then
            write(ntrace, &
                 '(" R8 C objected deleted: rank=",i5," size=",i10)') &
                 this%size_ptr-1, this%size
         endif
         this%handle = 0
      endif

      jjer=0

      icount=0
      if(associated(this%irow)) then
         icount=icount+1
         deallocate(this%irow, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(associated(this%values)) then
         icount=icount+1
         deallocate(this%values, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(associated(this%jcol_ptr)) then
         icount=icount+1
         deallocate(this%jcol_ptr, stat=jer)
         jjer=jjer+abs(jer)
      endif

      if(jjer/=0) ier = max(2,ier)

      this%nstate=-1

      if(icount.eq.3) then
         if(ntrace.ne.0) then
            write(ntrace, &
                 '(" F90 R8 objected deleted: rank=",i5," size=",i10)') &
                 this%size_ptr-1, this%size
         endif
      endif

    end subroutine sparseR8_free

    subroutine sparseR8_get_permc(this, ipermc, ier)

      implicit NONE
      type(sparseR8_obj) :: this
      integer, intent(out) :: ipermc  ! permutation control (returned)
      integer, intent(out) :: ier  !  status code; 0=OK

      ipermc=-1

      call sparseR8_icheck(this, ier)
      if(ier.ne.0) return

      ipermc = this%permc_spec

    end subroutine sparseR8_get_permc

    subroutine sparseR8_set_permc(this, ipermc, ier)

      implicit NONE
      type(sparseR8_obj) :: this
      integer, intent(in) :: ipermc  ! permutation control (set)
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseR8_icheck(this, ier)
      if(ier.ne.0) return

      this%permc_spec = ipermc

    end subroutine sparseR8_set_permc

    subroutine sparseR8_copy(this, that, ier)

      ! Copy this into that. this should contain data; 
      ! that should be initialized.

      implicit none
      type(sparseR8_obj) :: this, that
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseR8_icheck(this, ier)
      if(ier.ne.0) then
         ier=22  ! "from" object not initialized.
         return
      endif

      call sparseR8_icheck(that, ier)
      if(ier.ne.0) then
         ier=23  ! "to" object not initialized.
         return
      endif

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.  data required for copy.
         return
      endif

      !  free memory currently used by "that"; allocate matching size arrays
      call sparseR8_alloc(that, this%size_ptr-1, this%size, this%base, ier)

      that % nnz = this % nnz
      that % col_counter = this % col_counter
      that % row_rank = this % row_rank

      !  data array copies:
      that % irow = this%irow
      that % jcol_ptr = this%jcol_ptr
      that % values = this%values

      that % permc_spec = this%permc_spec

      that % nstate = 0
      that % handle = 0  ! C object not copied !

    end subroutine sparseR8_copy

    subroutine sparseR8_compare_shapes(this, that, ier)

      ! Compare two sparse matrices
      ! status code is set if shapes do not match, or if there is 
      ! some other error, e.g. "this" or "that" not initialized.

      implicit none
      type(sparseR8_obj) :: this, that
      integer, intent(out) :: ier  !  status code; 0 = SHAPES MATCH

      integer i

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      call sparseR8_icheck(that, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.  data required for compare.
         return
      endif

      if(that%nstate.lt.0) then
         ier=24  ! object contains no data.  data required for compare.
         return
      endif

      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_update_element(this, irow, jcol, value, ier)

      ! update specified element of sparse matrix
      ! if matrix has been factored, only an existing element can be
      ! updated; if the matrix is new, new elements may be added, but
      ! *only* in increasing order of row index within increasing order
      ! of column index.

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: irow    ! element row index
      integer, intent(in) :: jcol    ! element column index
      real(r8), intent(in) :: value  ! element value
      integer, intent(out) :: ier  !  status code; 0=OK

      integer :: i,ii,j,j1,imatch
      logical newcol_flag

      call sparseR8_dmark(this, ier)   ! verify initialization; mark update
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object not allocated
         return
      endif

      i = irow - this%base   ! i: 0,1,...,(N-1)
      j = jcol - this%base   ! j: 0,1,...,(N-1)
      j1 = j+1

      !  try for update first...

      imatch=0
      if( j1.gt.0 .and. (j1 .le. this%col_counter) ) then
         do ii = this%jcol_ptr(j1)+1,this%jcol_ptr(j1+1)
            if(this%irow(ii).eq.i) then
               imatch=ii
               exit
            endif
         enddo
      endif

      if(imatch.gt.0) then
         this%values(ii) = value
      else
         if(this%nstate.eq.0) then
            ! new element definition still possible...
            if(j1.eq.this%col_counter) then
               newcol_flag=.FALSE.
               call sparseR8_set_next(this, irow, newcol_flag, value, ier)
            else if(j1.eq.this%col_counter+1) then
               newcol_flag=.TRUE.
               call sparseR8_set_next(this, irow, newcol_flag, value, ier)
            else
               ier=31
            endif
         else
            ier=31
         endif
      endif

    end subroutine sparseR8_update_element

    subroutine sparseR8_update_column(this, nrow, irows, vals, jcol, ier)
      ! update elements in a column.

      ! if this is an update to elements of an existing column in a matrix
      ! that has already been defined, then, the rows specified must match
      ! exactly the sparsity pattern in the matrix as it was originally 
      ! defined.

      ! if the matrix is new, then, columns must be presented in ascending
      ! order, i.e. moving from left to right.

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: nrow        ! no. of rows
      integer, intent(in) :: irows(nrow) ! row indices
      real(r8), intent(in) :: vals(nrow)  ! corresponding element values
      integer, intent(in) :: jcol        ! column index
      integer, intent(out) :: ier  !  status code; 0=OK

      integer j,j1,inum,ii,imatch,iadr

      call sparseR8_dmark(this, ier)   ! verify initialization; mark update
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object not allocated.
         return
      endif

      j=jcol-this%base    ! get C (0-based) column index
      j1=j+1

      !  check for update
      if(j1.le.this%col_counter) then
         !  column already defined; enforce matching row elements
         inum = this%jcol_ptr(j1+1) - this%jcol_ptr(j1)
         if(inum.ne.nrow) then
            ier=32
         else
            imatch=1
            do ii=1,nrow
               iadr = this%jcol_ptr(j1)+ii
               if(irows(ii)-this%base .ne. this%irow(iadr)) then
                  imatch=0
                  exit
               endif
            enddo
            if(imatch.eq.0) then
               ier=32
            else
               iadr = this%jcol_ptr(j1)+1
               this%values(iadr:iadr+nrow-1)=vals(1:nrow)
            endif
         endif
      else if(j1.ne.this%col_counter+1) then
         !  new columns must be presented in ascending order
         ier=33
      else
         !  add new column
         call sparseR8_set_next_col(this, nrow, irows, vals, ier)
      endif

    end subroutine sparseR8_update_column

    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         ! element row index
      logical, intent(in) :: newcol_flag ! .TRUE. if new column, else .FALSE.
      real(r8), intent(in) :: value      ! element value
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object arrays not allocated.
         return
      endif

      if(this%nstate.gt.0) then
         ier=30  ! cannot add elements -- matrix already LU factorized.
         return
      endif

      if(newcol_flag) then
         this % col_counter = this % col_counter + 1
         if(this%col_counter.ge.this%size_ptr) then
            ier=1
            return
         endif
         this % jcol_ptr(this % col_counter) = this%nnz
      endif

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

    subroutine sparseR8_set_next_col(this, nrow, rowvec, valvec, ier)

      ! Set next column of values. Must iterate over columns
      ! running from left to right.
    
      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: nrow          ! no. of non-zero row elements
      integer, intent(in) :: rowvec(nrow)  ! element indices (ascending order)
      real(r8), intent(in) :: valvec(nrow) ! element values
      integer, intent(out) :: ier  !  status code; 0=OK

      integer :: istart,i

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object arrays not allocated.
         return
      endif

      if(this%nstate.gt.0) then
         ier=30  ! cannot add elements -- matrix already LU factorized.
         return
      endif

      this % col_counter = this % col_counter + 1
      if(this%col_counter.ge.this%size_ptr) then
         ier=1
         return
      endif
      this % jcol_ptr(this % col_counter) = this%nnz

      istart = this%nnz + 1
      this % nnz = this % nnz + nrow
      if(this % nnz > this % size) then         
         ier = 3
         return
      endif

      this % irow(istart:this%nnz) = rowvec - this%base
      do i=istart+1,this%nnz
         if( this%irow(i).le.this%irow(i-1) ) then
            ier=31  ! rows not given in ascending order
         endif
      enddo

      this % row_rank = max(this%row_rank, maxval(rowvec) - this%base + 1)

      this % values(istart:this%nnz) = valvec

      this % jcol_ptr(this % col_counter+1) = this%nnz
      
    end subroutine sparseR8_set_next_col

    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  !  status code; 0=OK

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      nrows = this % row_rank
      ncols = this % col_counter

    end subroutine sparseR8_get_size

    subroutine sparseR8_dmark(this, ier)

      !  mark that data has changed-- LU factorization needs to be 
      !  recomputed

      implicit none
      type(sparseR8_obj) :: this
      integer, intent(out) :: ier  !  status code; 0=OK

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      this%nstate = min(2, this%nstate)

    end subroutine sparseR8_dmark

    subroutine sparseR8_solve(this, rhs, ier)

      ! Solve matrix system  A*x=b
      ! "this" is A, "rhs" is b on input, x on output.
      
      implicit none
      type(sparseR8_obj) :: this
      real(r8), intent(inout) :: rhs(:) ! right-hand side vector;
                                        ! solution vector upon return
      integer, intent(out) :: ier  !  status code; 0=OK

      integer jer,n

      call sparseR8_factor(this, ier)
      if(ier.ne.0) return

      n=size(rhs)
      if(n.ne.this%row_rank) then
         ier=29  ! length of RHS vector must match rank of matrix
         return
      endif

      call dsupralu_solve(this%handle(1), rhs(1), jer)

      if(jer/=0) ier = 8

    end subroutine sparseR8_solve
 
    subroutine sparseR8_factor(this,ier)

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

      integer jer

      call sparseR8_icheck(this, ier)
      if(ier.ne.0) return   ! ier set if object was never initialized.

      if(this%nstate.lt.0) then
         ier=24  ! object contains no data.
         return
      endif

      !  LU factor a matrix -- but do not do more work than necessary

      if(this%row_rank.ne.this%col_counter) then
         ier=28
         return
      endif

      if(this%nstate.eq.0) then
         ! create C object; fetch C object handle
         call dsupralu_new( this%handle(1), &
              & this%values(1), this%irow(1), this%jcol_ptr(1), this%nnz, &
              & this%row_rank, &
              & jer)

         if(jer.ne.0) then
            this%handle = 0
            ier = 26
         else
            this%nstate = 1  ! C object successfully created.
            call dsupralu_msgs(this%handle(1), messages)
            if(ntrace.ne.0) then
               write(ntrace, &
                    '(" R8 C objected created: rank=",i5," size=",i10)') &
                    this%size_ptr-1, this%size
            endif
         endif
      endif
      if(ier.ne.0) return

      if(this%nstate.eq.1) then
         ! compute column permuation

         call dsupralu_colperm(this%handle(1), this % permc_spec, jer)
         if(jer.ne.0) then
            ier=27
         else
            this%nstate = 2  ! permutations obtained.
         endif
      endif

      if(this%nstate.eq.2) then
         ! compute LU factorization

         call dsupralu_lu(this%handle(1), jer)
         if(jer.ne.0) then
            ier=28
         else
            this%nstate = 3  ! LU factorization obtained.
         endif
      endif

    end subroutine sparseR8_factor

    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  !  status code; 0=OK

      call sparseR8_factor(this, ier)
      if(ier.ne.0) return
      
      call dsupralu_determinant(this%handle(1), res_mantissa, res_exponent, ier)
      if(ier/=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  !  status code; 0=OK

      integer i, k, rank, j

      ier = 0
      res = 0

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

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

    subroutine sparseR8_save(this, filename, ier)

      ! Save object data in netCDF file 'filename'

      use ezcdf
      implicit none
      type(sparseR8_obj) :: this
      character(*), intent(in) :: filename
      integer, intent(out) :: ier  !  status code; 0=OK

      integer ncid, jer

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

      if(this%nstate.lt.0) then
         ier=24  ! no data
         return
      endif

      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, 'row_rank', this%row_rank, 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_define(ncid, 'permc_spec', this%permc_spec, 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, 'row_rank', this%row_rank, 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_write(ncid, 'permc_spec', this%permc_spec, jer)

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

    end subroutine sparseR8_save

    subroutine sparseR8_load(this, filename, ier)

      ! Load data from netCDF file 'filename'
      ! Memory associated with existing data is deallocated first.

      use ezcdf
      implicit none
      type(sparseR8_obj) :: this
      character(*), intent(in) :: filename
      integer, intent(out) :: ier  !  status code; 0=OK

      integer ncid, jer

      integer isize,irank,ibase

      call sparseR8_icheck(this, ier)  ! verify initialization
      if(ier.ne.0) return

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

      call cdf_read(ncid, 'size', isize, jer)
      call cdf_read(ncid, 'size_ptr', irank, jer); irank = irank-1
      call cdf_read(ncid, 'base', ibase, jer)
      if(jer /= 0) then
         ier = 5
         call cdf_close(ncid, jer)
         return
      endif

      !  allocate space.  If object already has allocated space it is freed.
      call sparseR8_alloc(this, irank, isize, ibase, ier)
      if(ier.ne.0) then
         call cdf_close(ncid,jer)
         return
      endif

      call cdf_read(ncid, 'nnz', this%nnz, jer)
      call cdf_read(ncid, 'col_counter', this%col_counter, jer)
      call cdf_read(ncid, 'row_rank', this%row_rank, jer)

      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
      real(r8) :: tol, elems(10)
      real(r8), allocatable :: rhs(:), x(:), res(:), y(:)
      real(r8) :: lambda, adet, bdet, adet_mantissa, bdet_mantissa
      integer :: adet_exponent, bdet_exponent,irows(5)
      real(r8) :: cum_error

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

      base = 0 ! C-like
      !!! base = 1 ! fortran-like  (affects set/update calls below)
      rank = 5
      size = 10
      call sparseR8_init(this)
      call sparseR8_init(that)
      call sparseR8_alloc(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'

      do i=1,10
         elems(i)=(i-1)*1.0_r8
         if(i.le.5) irows(i)=i-1+base
      enddo

      !  set_next calls ... set in order, iterating down each column, moving
      !  through columns left to right.  Ordered "update_element" calls may
      !  also be used.... or "update_column" calls.

      call sparseR8_set_next(this, 0, .TRUE., 0._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 1, .FALSE., 1._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 0, .TRUE., 2._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 1, .FALSE., 3._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 2, .TRUE., 4._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 3, .FALSE., 5._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 4, .FALSE., 6._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 0, .TRUE., 7._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 3, .FALSE., 8._r8, ier); cum_error = cum_error + ier
      call sparseR8_set_next(this, 4, .TRUE., 9._r8, ier); cum_error = cum_error + ier

      call sparseR8_update_element(this, 0, 0, 0._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 1, 0, 1._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 0, 1, 2._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 1, 1, 3._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 2, 2, 4._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 3, 2, 5._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 4, 2, 6._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 0, 3, 7._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 3, 3, 8._r8, ier); cum_error = cum_error + ier
      call sparseR8_update_element(this, 4, 4, 9._r8, ier); cum_error = cum_error + ier

      call sparseR8_update_column(this, 2, (/0, 1/), elems(1:2), 0, ier); cum_error = cum_error + ier
      call sparseR8_update_column(this, 2, (/0, 1/), elems(3:4), 1, ier); cum_error = cum_error + ier
      call sparseR8_update_column(this, 3, (/2, 3, 4/), elems(5:7), 2, ier); cum_error = cum_error + ier
      call sparseR8_update_column(this, 2, (/0, 3/), elems(8:9), 3, ier); cum_error = cum_error + ier
      call sparseR8_update_column(this, 1, irows(5:5), elems(10:10), 4, ier); cum_error = cum_error + ier

      !  uncomment these ( and comment the above set/update calls) if base=1:

      !call sparseR8_update_column(this, 2, (/1, 2/), elems(1:2), 1, ier); cum_error = cum_error + ier
      !call sparseR8_update_column(this, 2, (/1, 2/), elems(3:4), 2, ier); cum_error = cum_error + ier
      !call sparseR8_update_column(this, 3, (/3, 4, 5/), elems(5:7), 3, ier); cum_error = cum_error + ier
      !call sparseR8_update_column(this, 2, (/1, 4/), elems(8:9), 4, ier); cum_error = cum_error + ier
      !call sparseR8_update_column(this, 1, irows(5:5), elems(10:10), 5, ier); cum_error = cum_error + 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), y(rank))
      rhs = (/ (i, i=1,rank) /)
      x = rhs
      print *, '...solving'
      call sparseR8_solve(this, x, ier)      
      call sparseR8_error(this, 6, 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))

      y=x

      ! redo problem with fortran-style indexing; compare result
      call sparseR8_free(this, ier)

      base = 1  ! fortran style
      call sparseR8_alloc(this, rank, size, base, ier)

      call sparseR8_set_next(this, 1, .TRUE., 0._r8, ier)
      call sparseR8_set_next(this, 2, .FALSE., 1._r8, ier)
      call sparseR8_set_next(this, 1, .TRUE., 2._r8, ier)
      call sparseR8_set_next(this, 2, .FALSE., 3._r8, ier)
      call sparseR8_set_next(this, 3, .TRUE., 4._r8, ier)
      call sparseR8_set_next(this, 4, .FALSE., 5._r8, ier)
      call sparseR8_set_next(this, 5, .FALSE., 6._r8, ier)
      call sparseR8_set_next(this, 1, .TRUE., 7._r8, ier)
      call sparseR8_set_next(this, 4, .FALSE., 8._r8, ier)
      call sparseR8_set_next(this, 5, .TRUE., 9._r8, ier)

      x = rhs
      call sparseR8_solve(this, x, ier)
      call sparseR8_error(this, 6, ier)
      cum_error = cum_error + ier

      print *,' fortran/C indexing differnce: ',sqrt(abs(sum((x - y)**2)/rank))
      cum_error = cum_error + sqrt(abs(sum((x - y)**2)/rank))

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

      print *,'...solve for different RHS vectors'
      ! re-use LU decomposition
      do i = 1, 4
         rhs = x ! copy
         call sparseR8_solve(that, x, ier)      
         cum_error = cum_error + ier
         call sparseR8_A_dot_x(that, x, res, ier)
         cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))
      enddo
      print *,' cumulative error: ',cum_error

      print *,'...solve for different matrices that share the same sparsity'
      ! re-use permutation matrices
      do i = 1, 4
         ! reset the values
         that % values = i * that % values
         call sparseR8_dmark(that, ier)
         rhs = x ! copy
         call sparseR8_solve(that, x, ier)      
         cum_error = cum_error + ier
         call sparseR8_A_dot_x(that, x, res, ier)
         cum_error = cum_error + sqrt(abs(sum((res - rhs)**2)/rank))         
      enddo
      print *,' cumulative error: ',cum_error

      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)
      call sparseR8_alloc(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)
      call sparseR8_alloc(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

      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)

      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 -- write message 
      
      implicit none
      type(sparseR8_obj) :: this
      integer, intent(in) :: nunit ! output channel (Fortran LUN)
      integer, intent(in) :: ier  !  status code  **INPUT**
      
      character(*), parameter :: header = 'SparseR8::'

    select case(ier)
       case(1)
          write(nunit, *) &
               & header//'ERROR: column counter exceeded declared rank: ', this%size_ptr-1
       case(2)
          write(nunit, *) header//'ERROR while deallocating'
       case(3)
          write(nunit, *) &
               & header//'ERROR: element counter exceeded declared size: ', this%size
       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 evaluation.'
       case(21)
          write(nunit, *) header//'ERROR: object used prior to initialization.'
       case(22)
          write(nunit, *) header//'ERROR: "from" object not initialized.'
       case(23)
          write(nunit, *) header//'ERROR: "to" object not initialized.'
       case(24)
          write(nunit, *) header//'ERROR: object contains no data.'
       case(25)
          write(nunit, *) header//'ERROR: SuperLU (C) object creation failed.'
       case(26)
          write(nunit, *) header//'ERROR: SuperLU error (column permutation).'
       case(27)
          write(nunit, *) header//'ERROR: SuperLU error (LU factorization).'
       case(28)
          write(nunit, *) header//'ERROR: row rank not equal to column rank:'
          write(nunit, *) '  row_rank = ',this%row_rank
          write(nunit, *) '  col_rank = ',this%col_counter
       case(29)
          write(nunit, *) header//'ERROR: RHS vector size .ne. matrix rank:'
          write(nunit, *) '  matrix rank is: ',this%row_rank
       case(30)
          write(nunit, *) &
               header//'ERROR: attempt to add elements after LU factorization.'
       case(31)
          write(nunit, *) &
               header//'ERROR: element definition out of order.'
       case(32)
          write(nunit, *) &
               header//'ERROR: row element mismatch in column update.'
       case(33)
          write(nunit, *) &
               header//'ERROR: column definition out of order.'
       
       case(999)
          write(nunit, *) header//'ERROR -- handle array allocation failure.'

       case(0)
          continue

       case default
          write(nunit, *) header//'ERROR (unspecified) ier = ',ier
    end select    
      
      
    end subroutine sparseR8_error

end module supralu_mod
