module functype
  !defining derived-types and operators between derived-types

  use parameters
  implicit none
  !position vector
  TYPE :: position
    REAL(rk)  :: x, y, z
  end type position
  !velocity vector
  TYPE :: velocity
    REAL(rk) :: vx, vy, vz
  end type velocity
 !acceleration vector
  TYPE :: acceleration
    REAL(rk):: ax, ay, az
  end type acceleration
  !all the data of an object is stored in this derived-type
  TYPE :: object
    INTEGER :: nimi          ! name of the object, an integer.
    TYPE(position) :: r
    TYPE(velocity) :: v
    TYPE(acceleration) :: a
    real(rk) :: m                       !mass
  end type object

 !the multiplication of two acceleration vectors
  interface operator(+)
    module procedure accadd
  end interface operator(+)

  !distance between two postion vectors
  interface operator(.etaisyys.)
    module procedure distance
  end interface operator(.etaisyys.)

contains

  !the multiplication of two acceleration vectors
  type(acceleration) function accadd(acc1, acc2)
    implicit none
    type(acceleration), INTENT(IN) :: acc1, acc2

    accadd%ax = acc1%ax+acc2%ax
    accadd%ay=  acc1%ay+acc2%ay
    accadd%az = acc1%az+acc2%az
  end function accadd

  !distance between two postion vectors
  real(rk) function distance(r1, r2)
    type(position), INTENT(IN) :: r1, r2

    distance= sqrt((r1%x- r2%x)**2+(r1%y- r2%y)**2+ (r1%z- r2%z)**2)

  end function distance

end module functype


!
! Tioga is a library for overset grid assembly on parallel distributed systems
! Copyright (C) 2015 Jay Sitaraman
!
subroutine getSpherePart(myid,numprocs,arange)
!
integer, intent(in) :: myid
integer, intent(in) :: numprocs
real*8, intent(out) :: arange(4)
!
integer :: i,nc,j,k
real*8 :: Ap,thetap,delta,Ai,a,thpolar
real*8, allocatable :: y(:)
integer, allocatable :: m(:)
real*8 :: pi
!
! begin
!
pi=acos(-1.)
Ap=4*pi/numprocs
!
thetap=asin(1-2.0/numprocs)
thpolar=pi*0.5-thetap
!
nc=nint((pi-2*thpolar)/sqrt(Ap))
delta=(pi-2*thpolar)/nc
!
allocate(y(nc),m(nc))
!
do i=1,nc
   Ai=2*pi*(sin(thetap-(i-1)*delta)-sin(thetap-i*delta))
   y(i)=Ai/Ap
enddo
!
a=0
do i=1,nc
   m(i)=nint(y(i)+a)
   a=a+(y(i)-m(i))
enddo
!
k=1
if (myid==k) then
  arange(1)=thetap
  arange(2)=pi*0.5
  arange(3)=0.
  arange(4)=2*pi
endif
!
do i=1,nc
   do j=1,m(i)
     k=k+1
     if (myid==k) then
        arange(1)=thetap-i*delta
	arange(2)=arange(1)+delta
        arange(3)=(j-1)*2*pi/m(i)
        arange(4)=arange(3)+2*pi/m(i)
	return
     endif
   enddo
enddo
!
k=numprocs
if (myid==k) then
  arange(1)=-pi*0.5
  arange(2)=-thetap
  arange(3)=0.
  arange(4)=2*pi
endif
!
!
return
end subroutine getSpherePart


c     program DRSRANGV
c>> 2001-05-22 DRSRANGV Krogh Minor change for making .f90 version.
c>> 1994-10-19 DRSRANGV Krogh  Changes to use M77CON
c>> 1987-12-09 DRSRANGV Lawson  Initial Code.
c--S replaces "?": DR?RANGV, ?RANGV
c        Demonstration driver for the Gaussian random vector generator,
c     SRANGV.
c     C. L. Lawson & S. Y. Chiu, JPL, Apr 1987.
c     ------------------------------------------------------------------
      integer I, J, N, IERR, NMAX, NSAMPL
      parameter(NMAX = 3)
      real             A(NMAX,NMAX), U(NMAX), X(NMAX)
      logical HAVEC
      data (U(  J),J=1,NMAX)/ 1.0E0,  2.0E0,  3.0E0 /
      data (A(1,J),J=1,NMAX)/ 0.05E0, 0.02E0, 0.01E0 /
      data (A(2,J),J=1,NMAX)/ 0.02E0, 0.07E0,-0.03E0 /
      data (A(3,J),J=1,NMAX)/ 0.01E0,-0.03E0, 0.06E0 /
c     ------------------------------------------------------------------
      N = NMAX
      NSAMPL = 20
      HAVEC = .false.
      print'(1x,a/1x)','Pseudorandom vectors computed by SRANGV'
      do 10 I = 1,NSAMPL
         call SRANGV(A, NMAX, N, U, X, HAVEC, IERR)
         if(IERR .ne. 0) then
            print '(1x,i3,i6)',N, IERR
         else
            print '(1x,i3,5x,3f12.3)',I,X
         endif
   10 continue
      stop
      end


module mod_jonesvec

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_jonesvec'
 !
 !          Purpose:
 !                    Implements so called 'Jones Vector'
 !
 !
 !          History:
 !                        Date: 08-08-2017
 !                        Time: 12:22 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:  Bernard Gingold
 !
 !
 !
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85

 ! Tab:5 col - Type and etc.. definitions
 ! Tab:10,11 col - Type , function and subroutine code blocks.

    implicit none
    use module_kinds
    use module_logger

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_JONESVEC_MAJOR = 1

    ! Minor version
    integer(I32P), parameter, public :: MOD_JONESVEC_MINOR = 0

    ! Micro version
    integer(I32P), parameter, public :: MOD_JONESVEC_MICRO = 0

    ! Module/file full version
    integer(I32P), parameter, public :: MOD_JONESVEC_FULLVER = 1000*MOD_JONESVEC_MAJOR+100*MOD_JONESVEC_MINOR + &
                                                               10*MOD_JONESVEC_MICRO

    ! Module/file creation date
    character(*),  parameter, public :: MOD_JONESVEC_CREATE_DATE = "08-08-2017 12:30 +00200 (TUE 08 AUG 2017 GMT+2)"

    ! Module/file build date/time (should be set to appropriate values after successful build date)
    character(*),  parameter, public :: MOD_JONESVEC_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_JONESVEC_AUTHOR = "Programmer: Bernard Gingold e-mail:beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_JONESVEC_DESCRIPT = "Implementation of Jones Vector"

    complex(R64P), parameter, private :: ZC = DCMPLX(0._R64P,0._R64P)

    !============================================50
    ! Type: JonesVector_t
    !============================================50

    type :: JonesVector_t

         private

         ! Horizontal component of Electric Field Hx
         complex(R64P) :: m_h

         ! Vertical component of Electric Field Hy
         complex(R64P) :: m_v

         ! Logical indicator set to true if
         ! object is created
         logical(I32P) :: m_isbuilt
        !============================================================70
        !    Type-bound procedures
        !    Decalaration
        !============================================================70

        contains

        ! Destructor

        procedure, pass(this), public :: destroy_jvec

        ! Getters

        procedure, pass(this), public :: get_h

        procedure, pass(this), public :: get_v

        procedure, pass(this), public :: get_built_status

        ! Computational procedures

        procedure, pass(this), public :: field_intensity

        procedure, pass(this), public :: field_atan

        procedure, pass(this), public :: field_pdiff

        procedure, pass(this), public :: polarization_degree

        procedure, pass(this), public :: jvec_conj

        ! helpers
        procedure, nopass, public :: print_jvec

        end type JonesVector_t
    !============================================50
    ! Declaration of module operators
    !============================================50

    ! Constructor bound to name JonesVector_t

    interface  JonesVector_t

        procedure :: default_jvec

        procedure :: create_jvec

        procedure :: copy_jvec

    end interface

    ! Operator assignment

    interface assignment (=)

          module procedure assign_jvec

    end interface

    ! Operator multiplication

    interface operator (*)

          module procedure jvec_mul_jvec
          module procedure jvec_mul_complex

   end interface

    ! Operator division

    interface operator (/)

          module procedure jvec_div_complex

    end interface

    ! Operator addition

    interface operator (+)

          module procedure jvec_add_jvec

    end interface

    ! Operator subtraction

    interface operator (-)

          module procedure jvec_negate
          module procedure jvec_sub_jvec

    end interface

    contains

    !======================================================60
    !  function: default_jvec
    !            Creates JonesVector_t with its two fields
    !            set to zero.
    !======================================================60
    type(JonesVector_t) function default_jvec()
          implicit none
          ! Start of executable statements
          default_jvec%m_h = DCMPLX(0._R64P,0._R64P)
          default_jvec%m_v = DCMPLX(0._R64P,0._R64P)
          default_jvec%m_isbuilt = .true.
    end function

    !======================================================60
    !  function: create_jvec
    !            Creates JonesVector_t with its two fields
    !            set to specific polarization values.
    !======================================================60
    type(JonesVector_t) function create_jvec(h,v)
          implicit none
          complex(R64P), intent(in) :: h,v
          ! Start of executable statements
          create_jvec%m_h = h
          create_jvec%m_v = v
          create_jvec%m_isbuilt = .true.
    end function

    !======================================================60
    !  function: copy_jvec
    !            Creates JonesVector_t with its two fields
    !            set to copy of its argument.
    !======================================================60
    type(JonesVector_t) function copy_jvec(other)
          use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT
          implicit none
          class(JonesVector_t), intent(in) :: other
          ! Start of executable statements
          if(other%m_isbuilt .EQ. .false.) then
              write(stderr,*) "copy_jvec:236, Argument in destroyed state!"
              return
          end if
          copy_jvec%m_h = other%m_h
          copy_jvec%m_v = other%m_v
          copy_jvec%m_isbuilt = .true.
    end function

    !======================================================60
    !  subroutine: destroy_jvec
    !              Destroys JonesVector_t by settings its
    !              members to invalid values.
    !======================================================60
    subroutine destroy_jvec(this)
          use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT
          use IEEE_ARITHMETIC, only : IEEE_VALUE
          implicit none
          class(JonesVector_t), intent(inout) :: this
          ! Locals
          real(R64P) :: nan
          ! Start of executable statements
          if(this%m_isbuilt .EQ. .false.) then
              write(stderr,*) "destroy_jvec:261, JonesVector_t already destroyed!"
              return
          end if
          nan = IEEE_VALUE(1._R64P,IEEE_QUIET_NAN)
          this%m_h = DCMPLX(nan,nan)
          this%m_v = DCMPLX(nan,nan)
          this%m_isbuilt = .false.
    end subroutine

    !======================================================60
    ! function: get_h
    !======================================================60
    pure function get_h(this) result(h)
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Locals
          complex(R64P) :: h
          ! Start of executable statements
          h = this%m_h
    end function

    !======================================================60
    ! function: get_v
    !======================================================60
    pure function get_v(this) result(v)
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Locals
          complex(R64P) :: v
          ! Start of executable statements
          v = this%m_v
    end function

    !======================================================60
    ! function: get_built_status
    !======================================================60
    pure function get_built_status(this) result(isbuilt)
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Locals
          logical(I32P) :: isbuilt
          ! Start of executable statements
          isbuilt = this%m_isbuilt
    end function

    !======================================================60
    ! function: field_intensity
    !======================================================60
    pure function field_intensity(this) result(norm)
          use mod_complex_arithm, only : cnorm
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Locals
          real(R64P) :: norm
          ! Start of executable statements
          norm = cnorm(this%m_h)+cnorm(this%m_v)
    end function

    !======================================================60
    ! function: field_atan
    !======================================================60
    pure function field_atan(this) result(ang)
          use mod_complex_arithm, only : cmag
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Locals
          real(R64P) :: ang,tmp
          ! Start of executable statements
          tmp = cmag(this%m_v)/cmag(this%m_h)
          ang = DATAN(tmp)
    end function

    !======================================================60
    ! function: field_pdiff
    !======================================================60
    pure function field_pdiff(this) result(pdiff)
         use mod_complex_arithm, only : carg
         implicit none
         class(JonesVector_t), intent(in) :: this
         ! Locals
         real(R64P) :: pdiff
         ! Start of executable statements
         pdiff = carg(this%m_v)-carg(this%m_h)
    end function

    !======================================================60
    ! function: polarization_degree
    !======================================================60
     pure function polarization_degree() return(val)
          implicit none
          ! Locals
          real(R64P) :: val
          val = 1._R64P
    end function

    !======================================================60
    ! function: jvec_conj
    !======================================================60
    pure function jvec_conj(jv1) result(njvec)
          implicit none
          class(JonesVector_t), intent(in) :: jv1
          ! Locals
          class(JonesVector_t) :: njvec
          ! Start of executable statements
          njvec = JonesVector_t(DCONJG(jv1%m_h),DCONJG(jv1%m_v))
    end function

    !======================================================60
    ! subroutine: print_jvec
    !======================================================60
    subroutine print_jvec(this)
          implicit none
          class(JonesVector_t), intent(in) :: this
          ! Start of executable statements
          print*, "==============================================="
          print*, " Vertical component   'v'   ", this%m_v
          print*, " Horizontal component 'h'   ", this%m_h
          print*, " JonesVector_t build status:", this%m_isbuilt
          print*, "================================================"
    end subroutine

    !======================================================60
    ! subroutine:  assignmemt (=)
    !
    !======================================================60
    subroutine assign_jvec(this,other)
          use ISO_FORTRAN_ENV, only : stderr=>ERROR_UNIT
          implicit none
          class(JonesVector_t), intent(inout) :: this
          class(JonesVector_t), intent(in)    :: other
          ! Start of executable statements
          if(LOC(this).EQ.LOC(other)) then
              write(stderr,*) "assign_jvec:382, Attempted self-assignment!"
              return
          end if
          this%m_h = other%m_h
          this%m_v = other%m_v
          this%m_isbuilt = other%m_isbuilt
    end subroutine

    !======================================================60
    ! function: jvec_mul_jvec
    ! Remark: valid only for: conjg(this)*jv1
    !======================================================60
    pure function jvec_mul_jvec(this,jv1) result(c)
          implicit none
          class(JonesVector_t), intent(in) :: this
          class(JonesVector_t), intent(in) :: jv1
          ! Locals
          complex(R64P) :: c
          ! Start of executable statements
          c = this%m_h*jv1%m_h+this%m_v*jv1%m_v
    end function

    !======================================================60
    !  function: jvec_mul_complex
    !======================================================60
    pure function jvec_mul_complex(this,c) result(njvec)
          implicit none
          class(JonesVector_t), intent(in) :: this
          complex(R64P),        intent(in) :: c
          ! Locals
          class(JonesVector_t) :: njvec
          ! Start of executable statements
          njvec%m_h = this%m_h*c
          njvec%m_v = this%m_v*c
          njvec%m_isbuilt = .true.
    end function

    !======================================================60
    !  function: jvec_div_complex
    !======================================================60
    pure function jvec_div_complex(this,c) result(njvec)
          implicit none
          class(JonesVector_t), intent(in) :: this
          complex(R64P),        intent(in) :: c
          ! Start of executable statements
          if(c.EQ.ZC) then
              print*, "operator (/):446, Attempted division by (0.0,0.0)"
              return
         end if
         njvec%m_h = this%m_h/c
         njvec%m_v = this%m_v/c
         njvec%m_isbuilt = .true.
    end function

    !======================================================60
    ! function: jvec_add_jvec
    !======================================================60
    pure function jvec_add_jvec(this,other) result(njvec)
          implicit none
          class(JonesVector_t), intent(in) :: this,other
          ! Locals
          class(JonesVector_t) :: njvec
          ! Start of executable statements
          njvec = JonesVector_t(this%m_h+other%m_h, &
                                this%m_v+other%m_v )
    end function

    !======================================================60
    ! function: jvec_negate
    !======================================================60
    pure function jvec_negate(this) result(njvec)
          implicit none
          class(JonesVector_t), intent(inout) :: this
          ! Locals
          class(JonesVector_t) :: njvec
          ! Start of executable statements
          njvec = JonesVector_t(-this%m_h,-this%m_v)
    end function

    !======================================================60
    ! function: jvec_sub_jvec
    !======================================================60
    pure function jvec_sub_jvec(this,other) result(njvec)
          implicit none
          class(JonesVector_t), intent(in) :: this,other
          ! Lcals
          class(JonesVector) :: njvec
          ! Start of executable statements
          njvec = JonesVector_t(this%m_h-other%m_h, &
                                this%m_v-other%m_v)
    end function

end module mod_jonesvec


module modtest_crs
#if (_DP==0)
 use, intrinsic :: iso_fortran_env, only: int64, wp => real32
#else
 use, intrinsic :: iso_fortran_env, only: int64, wp => real64
#endif
 use testdrive, only: new_unittest, unittest_type, error_type, check
 use modsparse, only: coosparse, crssparse, assignment(=)
 use modtest_common, only: tol_wp, verbose, ia, ja, a, aspsd, addval => addval_coo&
                       , getmat, matcheck, printmat
 implicit none
 private

 public :: collect_crs

 integer, parameter :: sparse_unit = 556

contains

!> Collect all exported unit tests
subroutine collect_crs(testsuite)
  !> Collection of tests
  type(unittest_type), allocatable, intent(out) :: testsuite(:)

  !how to test: getordering, print, printsquare, save, sort

  testsuite = [ &
    new_unittest("crs constructor", test_constructor) &
    , new_unittest("crs add", test_add) &
    , new_unittest("crs add nel", test_add_nel) &
    , new_unittest("crs add lupper", test_add_lupper) &
    , new_unittest("crs ncol add", test_ncol_add) &
    , new_unittest("crs ncol add nel", test_ncol_add_nel) &
    , new_unittest("crs ncol add lupper", test_ncol_add_lupper) &
    , new_unittest("crs cg", test_cg) &
#if (_SPAINV==1)
    , new_unittest("crs chol", test_chol) &
#endif
    , new_unittest("crs diag vect", test_diag_vect) &
    , new_unittest("crs diag vect lupper", test_diag_vect_lupper) &
    , new_unittest("crs ncol diag vect", test_ncol_diag_vect) &
    , new_unittest("crs ncol diag vect lupper", test_ncol_diag_vect_lupper) &
    , new_unittest("crs get", test_get) &
    , new_unittest("crs get nel", test_get_nel) &
    , new_unittest("crs get lupper", test_get_lupper) &
    , new_unittest("crs get lupper_sym", test_get_lupper_sym) &
    , new_unittest("crs ncol get", test_ncol_get) &
    , new_unittest("crs ncol get nel", test_ncol_get_nel) &
    , new_unittest("crs ncol get lupper", test_ncol_get_lupper) &
#if (_SPAINV==1)
    , new_unittest("crs ichol", test_ichol) &
    , new_unittest("crs ichol_failed", test_ichol_failed, should_fail = .true.) &
    , new_unittest("crs isolve", test_isolve) &
    , new_unittest("crs ldlt", test_ldlt) &
#endif
    , new_unittest("crs multbyv_n_n_n", test_multbyv_n_n_n) &
    , new_unittest("crs multbyv_n_n_y", test_multbyv_n_n_y) &
    , new_unittest("crs multbyv_n_y_n", test_multbyv_n_y_n) &
    , new_unittest("crs multbyv_n_y_y", test_multbyv_n_y_y) &
    , new_unittest("crs multbyv_y_n_n", test_multbyv_y_n_n) &
    , new_unittest("crs multbyv_y_n_y", test_multbyv_y_n_y) &
    , new_unittest("crs multbyv_y_y_n", test_multbyv_y_y_n) &
    , new_unittest("crs multbyv_y_y_y", test_multbyv_y_y_y) &
    , new_unittest("crs multbyv_sym", test_multbyv_sym) &
    , new_unittest("crs multbyv_sym1", test_multbyv_sym1) &
    , new_unittest("crs multbymat_n_n_n", test_multbymat_n_n_n) &
    , new_unittest("crs multbymat_n_n_y", test_multbymat_n_n_y) &
    , new_unittest("crs multbymat_n_y_n", test_multbymat_n_y_n) &
    , new_unittest("crs multbymat_n_y_y", test_multbymat_n_y_y) &
    , new_unittest("crs multbymat_y_n_n", test_multbymat_y_n_n) &
    , new_unittest("crs multbymat_y_n_y", test_multbymat_y_n_y) &
    , new_unittest("crs multbymat_y_y_n", test_multbymat_y_y_n) &
    , new_unittest("crs multbymat_y_y_y", test_multbymat_y_y_y) &
    , new_unittest("crs multbymat_sym", test_multbymat_sym) &
    , new_unittest("crs multbymat_sym1", test_multbymat_sym1) &
    , new_unittest("crs nonzero", test_nonzero) &
    , new_unittest("crs nonzero_sym", test_nonzero_sym) &
    , new_unittest("crs scale", test_scale) &
#if (_PARDISO==1)
    , new_unittest("crs solveldlt", test_solve_vector) &
    , new_unittest("crs solveldlt", test_solve_vector_perm) &
    , new_unittest("crs solveldlt_arr", test_solve_array) &
    , new_unittest("crs solveldlt_arr", test_solve_array_perm) &
#else
    , new_unittest("crs solveldlt", test_solve_vector, should_fail = .true.) &
    , new_unittest("crs solveldlt", test_solve_vector_perm, should_fail = .true.) &
    , new_unittest("crs solveldlt_arr", test_solve_array, should_fail = .true.) &
    , new_unittest("crs solveldlt_arr", test_solve_array_perm, should_fail = .true.) &
#endif
#if (_SPAINV==1)
    , new_unittest("crs solveldlt", test_solveldlt) &
    , new_unittest("crs spainv", test_spainv) &
    , new_unittest("crs spainv_failed", test_spainv_failed, should_fail = .true.) &
#endif
    , new_unittest("crs submatrix_off_full_full", test_submatrix_off_full_full) &
    , new_unittest("crs submatrix_off_full_upper", test_submatrix_off_full_upper) &
    , new_unittest("crs submatrix_off_upper_full", test_submatrix_off_upper_full) &
    , new_unittest("crs submatrix_full_full", test_submatrix_full_full) &
    , new_unittest("crs submatrix_full_upper", test_submatrix_full_upper) &
    , new_unittest("crs submatrix_upper_full", test_submatrix_upper_full) &
    ]

  !to check: diag_mat

end subroutine collect_crs

!CONSTRUCTOR + GETDIM + ISSQUARE
subroutine test_constructor(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 integer, parameter :: nel = 9
 type(crssparse) :: crs

 crs = crssparse(nrow, nel)
 call check(error, crs%getdim(1), nrow, more = 'getdim(1)')
 call check(error, crs%getdim(2), nrow, more = 'getdim(2)')
 call check(error, crs%getdim(3) < 0, more = 'getdim(3)')
 call check(error, crs%issquare(), nrow.eq.nrow, 'isquare')
 if (allocated(error)) return

 crs = crssparse(nrow, nel, lupper = .true.)
 call check(error, crs%getdim(1), nrow, more = 'getdim(1)')
 call check(error, crs%getdim(2), nrow, more = 'getdim(2)')
 call check(error, crs%issquare(), nrow.eq.nrow, 'isquare')
 if (allocated(error)) return

 crs = crssparse(nrow, nel, n = ncol)
 call check(error, crs%getdim(1), nrow, more = 'getdim(1)')
 call check(error, crs%getdim(2), ncol, more = 'getdim(2)')
 call check(error, crs%issquare(), nrow.eq.ncol, 'isquare')
 if (allocated(error)) return

 crs = crssparse(nrow, nel, n = ncol, lupper = .true.)
 call check(error, crs%getdim(1), nrow, more = 'getdim(1)')
 call check(error, crs%getdim(2), ncol, more = 'getdim(2)')
 call check(error, crs%issquare(), nrow.eq.ncol, 'isquare')
 if (allocated(error)) return

 crs = crssparse(nrow, nel, n = ncol, lupper = .true., unlog = sparse_unit)
 call check(error, crs%getdim(1), nrow, more = 'getdim(1)')
 call check(error, crs%getdim(2), ncol, more = 'getdim(2)')
 call check(error, crs%issquare(), nrow.eq.ncol, 'isquare')
 if (allocated(error)) return

end subroutine

!ADD
subroutine test_add(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

subroutine test_add_nel(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, nel = 4_int64, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

subroutine test_add_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia .le. ja

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

subroutine test_ncol_add(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

subroutine test_ncol_add_nel(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, nel = 2_int64,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

subroutine test_ncol_add_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) =  ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call getija_crs(crs, iat, jat, at, mat)

 call check(error, size(iat), size(pack(ia, lvalid)), more = 'size(iat)')
 call check(error, size(jat), size(pack(ja, lvalid)), more = 'size(jat)')
 call check(error, size(at), size(pack(a, lvalid)), more = 'size(at)')
 if (allocated(error)) return

 call check(error, all(iat == pack(ia, lvalid)), 'ia')
 call check(error, all(jat == pack(ja, lvalid)), 'ja')
 call check(error, all(at == pack(a, lvalid)), 'a')
 if (allocated(error)) return

 if(verbose)call printmat(mat)

end subroutine

!CG
subroutine test_cg(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 integer :: maxiter
 real(wp) :: tol
 real(wp) :: xmat(nrow, ncol)
 real(wp) :: mat_l(nrow, ncol)
 real(wp) :: y(ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)
 call coo%add(2, 2, 202._wp) !to set the matrix SPD

 crs = coo

 xmat = 0
 do i = 1, ncol
  tol = 1.e-6
  maxiter = nrow
  y = 0
  y(i) = 1
  call crs%cg(xmat(:,i), y, maxiter, tol)
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(getmat(crs) <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(matmul(getmat(crs), xmat) - mat_l) < tol_wp), 'crs cg')

end subroutine

#if (_SPAINV==1)
!CHOLESKY FACTOR
subroutine test_chol(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = nrow
 integer, parameter :: perm(nrow) = [(i, i =nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 real(wp) :: matchol(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

! call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2]&
!             , merge([a, 22._wp] + 1000, [a, 22._wp], [ia, 2] ==  [ja, 2]))
 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !Complete Cholesky decomposition
 call crs%setpermutation(perm)
 call crs%chol()

 deallocate(iat); deallocate(jat); deallocate(at)
 call getija_crs(crs, iat, jat, at, matchol)

 call check(error, all(abs(mat(perm, perm) - &
                       matmul(transpose(matchol), matchol)) < tol_wp)&
                 , 'Chol')
 if(allocated(error))return

 !Complete Cholesky decomposition
 crs = coo
 call crs%setpermutation(permf(nrow))
 call crs%chol()

 deallocate(iat); deallocate(jat); deallocate(at)
 call getija_crs(crs, iat, jat, at, matchol)

 call check(error, all(abs(mat(permf(nrow), permf(nrow)) - &
                       matmul(transpose(matchol), matchol)) < tol_wp)&
                 , 'Chol_permf')

end subroutine
#endif

!DIAG VECT
subroutine test_diag_vect(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.eq.ja
 integer, parameter :: sizediag =min(nrow, ncol)

 real(wp) :: diagcheck(sizediag)
 real(wp), allocatable :: diag(:)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 diag = crs%diag()

 diagcheck = 0
 diagcheck(pack(ia, lvalid)) = pack(a, lvalid)

 call check(error, size(diag), sizediag, more = 'size(diag)')
 if (allocated(error)) return
 if (allocated(error)) return

 call check(error, all(diag == diagcheck), 'diag')

end subroutine

subroutine test_diag_vect_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.eq.ja
 integer, parameter :: sizediag = min(nrow, ncol)

 real(wp) :: diagcheck(sizediag)
 real(wp), allocatable :: diag(:)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a)

 crs = coo

 diag = crs%diag()

 diagcheck = 0
 diagcheck(pack(ia, lvalid)) = pack(a, lvalid)

 call check(error, size(diag), sizediag, more = 'size(diag)')
 if (allocated(error)) return
 if (allocated(error)) return

 call check(error, all(diag == diagcheck), 'diag')

end subroutine

subroutine test_ncol_diag_vect(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.eq.ja
 integer, parameter :: sizediag = min(nrow, ncol)

 real(wp) :: diagcheck(sizediag)
 real(wp), allocatable :: diag(:)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol,  unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 diag = crs%diag()

 diagcheck = 0
 diagcheck(pack(ia, lvalid)) = pack(a, lvalid)

 call check(error, size(diag), sizediag, more = 'size(diag)')
 if (allocated(error)) return

 call check(error, all(diag == diagcheck), 'diag')

end subroutine

subroutine test_ncol_diag_vect_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.eq.ja
 integer, parameter :: sizediag = min(nrow, ncol)

 real(wp) :: diagcheck(sizediag)
 real(wp), allocatable :: diag(:)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol,  unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 diag = crs%diag()

 diagcheck = 0
 diagcheck(pack(ia, lvalid)) = pack(a, lvalid)

 call check(error, size(diag), sizediag, more = 'size(diag)')
 if (allocated(error)) return

 call check(error, all(diag == diagcheck), 'diag')

end subroutine

!GET
subroutine test_get(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, unlog = sparse_unit)
 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

subroutine test_get_nel(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, nel = 4_int64, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

subroutine test_get_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia .le. ja

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

subroutine test_get_lupper_sym(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia .le. ja

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == &
             matcheck(nrow, ncol, ia, ja, a, lvalid) &
             + transpose(matcheck(nrow, ncol, ia, ja, a, lvalid .and. ia.lt.ja)))&
             , 'get sym')

end subroutine

subroutine test_ncol_get(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

subroutine test_ncol_get_nel(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, nel = 2_int64,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

subroutine test_ncol_get_lupper(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) =  ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call check(error, all(getmat(crs) == matcheck(nrow, ncol, ia, ja, a, lvalid)), 'get')

end subroutine

#if (_SPAINV==1)
!ICHOL
subroutine test_ichol(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = 1, nrow)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: matchol(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crschol
 logical :: lvalid(nrow, nrow)

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2], [aspsd, 0._wp])

 !ICHOL
 !Cholesky
 crschol= coo
 call crschol%setpermutation(perm)
 call crschol%chol()

 call getija_crs(crschol, iat, jat, at, matchol)

 crs = coo

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat)

 call crs%setpermutation(perm)
 call crs%ichol()

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat_l)

 lvalid = mat(perm, perm).ne.0

 call check(error, all(abs(pack(mat_l, lvalid) - pack(matchol, lvalid)) < tol_wp), 'ichol')
 if(allocated(error))return

 !ICHOL
 !Cholesky
 crschol= coo
 call crschol%setpermutation(permf(nrow))
 call crschol%chol()

 call getija_crs(crschol, iat, jat, at, matchol)

 crs = coo

 call crs%setpermutation(permf(nrow))
 call crs%ichol()

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat_l)

 lvalid = mat(permf(nrow), permf(nrow)).ne.0

 call check(error, all(abs(pack(mat_l, lvalid) - pack(matchol, lvalid)) < tol_wp), 'ichol_permf')

end subroutine

subroutine test_ichol_failed(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = 1, nrow)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: matchol(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crschol

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2], [aspsd, 0._wp])

 !Cholesky
 crschol= coo
 call crschol%setpermutation(perm)
 call crschol%chol()

 call getija_crs(crschol, iat, jat, at, matchol)

 !ICHOL
 crs = coo

 call crs%setpermutation(perm)
 call crs%ichol()

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat_l)

 call check(error, all(abs(mat_l - matchol) < tol_wp), 'should_ichol_failed')

end subroutine

!ISOLVE
subroutine test_isolve(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 !mat must be SPD
 call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2]&
             , merge([a, 22._wp] + 1000, [a, 22._wp], [ia, 2] ==  [ja, 2]))

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !Cholesky
 call crs%setpermutation(perm)
 call crs%chol()

 do i = 1, nrow
  call crs%isolve(mat_d(:,i), mat(:,i))
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'isolve')
 if(allocated(error))return

 !Cholesky
 crs = coo

 call crs%setpermutation(permf(nrow))
 call crs%chol()

 do i = 1, nrow
  call crs%isolve(mat_d(:,i), mat(:,i))
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'isolve_permf')

end subroutine

!LDLt
subroutine test_ldlt(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: ncol = nrow
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !LDLt
 call crs%setpermutation(perm)
 call crs%getldlt()

 deallocate(iat); deallocate(jat); deallocate(at)
 call getija_crs(crs, iat, jat, at, mat_l)

 mat_d = 0
 do i = 1, nrow
  mat_d(i, i) = mat_l(i, i)
  mat_l(i, i) = 1
 enddo

 call check(error, all(abs(mat(perm, perm) - &
                       matmul(transpose(mat_l), matmul(mat_d, mat_l))) < tol_wp)&
                 , 'LDLt')

 !LDLt
 crs = coo
 call crs%setpermutation(permf(nrow))
 call crs%getldlt()

 deallocate(iat); deallocate(jat); deallocate(at)
 call getija_crs(crs, iat, jat, at, mat_l)

 mat_d = 0
 do i = 1, nrow
  mat_d(i, i) = mat_l(i, i)
  mat_l(i, i) = 1
 enddo

 call check(error, all(abs(mat(permf(nrow), permf(nrow)) - &
                       matmul(transpose(mat_l), matmul(mat_d, mat_l))) < tol_wp)&
                 , 'LDLt_permf')

end subroutine
#endif

!MULT BY VECT
subroutine test_multbyv_n_n_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'n', trans = 'n', upper = 'n')
end subroutine

subroutine test_multbyv_n_n_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'n', trans = 'n', upper = 'y')
end subroutine

subroutine test_multbyv_n_y_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'n', trans = 'y', upper = 'n')
end subroutine

subroutine test_multbyv_n_y_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'n', trans = 'y', upper = 'y')
end subroutine

subroutine test_multbyv_y_n_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'y', trans = 'n', upper = 'n')
end subroutine

subroutine test_multbyv_y_n_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'y', trans = 'n', upper = 'y')
end subroutine

subroutine test_multbyv_y_y_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'y', trans = 'y', upper = 'n')
end subroutine

subroutine test_multbyv_y_y_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbyv_gen(error, col = 'y', trans = 'y', upper = 'y')
end subroutine

subroutine test_multbyv_sym(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp
 real(wp), parameter :: x(ncol) = [(real(i, wp), i = 1, ncol)]
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 real(wp) :: y(nrow), ycheck(nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 y = 1._wp
 call crs%mult(alpha, 'n', x, val, y)

 ycheck = 1._wp
 ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
     + transpose(matcheck(nrow, ncol, ia, ja, a, lvalid .and. ia.lt.ja))&
   , x)

 call check(error, all(abs(y - ycheck) < tol_wp), 'multbyv_sym')

end subroutine

subroutine test_multbyv_sym1(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp
 real(wp), parameter :: x(ncol) = [(real(i, wp), i = 1, ncol)]
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 real(wp) :: y(nrow), ycheck(nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call crs%setsymmetric()

 y = 1._wp
 call crs%mult(alpha, 'n', x, val, y)

 ycheck = 1._wp
 ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
     + transpose(matcheck(nrow, ncol, ia, ja, a, lvalid .and. ia.lt.ja))&
   , x)

 call check(error, all(abs(y - ycheck) < tol_wp), 'multbyv_sym')

end subroutine

subroutine test_multbyv_gen(error, col, trans, upper)
 character(len=*), intent(in) :: col
 character(len=*), intent(in) :: trans
 character(len=*), intent(in) :: upper
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp

 integer :: i, ncol
 real(wp), allocatable :: x(:), y(:), ycheck(:)
 logical :: lvalid(size(ia))
 type(coosparse) :: coo
 type(crssparse) :: crs

 ncol = merge(4, nrow, col == 'y')

 if(upper == 'y')then
  lvalid = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja
 else
  lvalid = ia.le.nrow .and. ja.le.ncol
 endif

 allocate(x(merge(nrow, ncol, trans == 'y')), source = &
                              [(real(i, wp), i = 1, merge(nrow, ncol, trans == 'y'))])
 allocate(y(merge(ncol, nrow, trans == 'y')), source = 1._wp)
 allocate(ycheck(merge(ncol, nrow, trans == 'y')), source = 1._wp)

 if(col == 'y')then
  if(upper == 'y')then
   coo = coosparse(nrow, n = ncol, lupper = .true., unlog = sparse_unit)
  else
   coo = coosparse(nrow, n = ncol, unlog = sparse_unit)
  endif
 else
  if(upper == 'y')then
   coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
  else
   coo = coosparse(nrow, unlog = sparse_unit)
  endif
 endif

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call crs%mult(alpha, merge('t', 'n', trans == 'y'), x, val, y)

 if(trans == 'y')then
  ycheck = ycheck * val + alpha * matmul(&
   transpose(matcheck(nrow, ncol, ia, ja, a, lvalid)) &
   , x)
 else
  ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
   , x)
 endif

 call check(error, all(abs(y - ycheck) < tol_wp)&
                 , 'multbyv_'//col//'_'//trans//'_'//upper)

end subroutine

!MULT BY MAT
subroutine test_multbymat_n_n_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'n', trans = 'n', upper = 'n')
end subroutine

subroutine test_multbymat_n_n_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'n', trans = 'n', upper = 'y')
end subroutine

subroutine test_multbymat_n_y_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'n', trans = 'y', upper = 'n')
end subroutine

subroutine test_multbymat_n_y_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'n', trans = 'y', upper = 'y')
end subroutine

subroutine test_multbymat_y_n_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'y', trans = 'n', upper = 'n')
end subroutine

subroutine test_multbymat_y_n_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'y', trans = 'n', upper = 'y')
end subroutine

subroutine test_multbymat_y_y_n(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'y', trans = 'y', upper = 'n')
end subroutine

subroutine test_multbymat_y_y_y(error)
 type(error_type), allocatable, intent(out) :: error

 call test_multbymat_gen(error, col = 'y', trans = 'y', upper = 'y')
end subroutine

subroutine test_multbymat_sym(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrhs = 3
 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp
 real(wp), parameter :: x(ncol, nrhs) = 1._wp
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 real(wp) :: y(nrow, nrhs), ycheck(nrow, nrhs)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 y = 1._wp
 call crs%mult(alpha, 'n', x, val, y)

 ycheck = 1._wp
 ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
   + transpose(matcheck(nrow, ncol, ia, ja, a, lvalid .and. ia.lt.ja))&
   , x)

 call check(error, all(abs(y - ycheck) < tol_wp), 'multbymat_sym')

end subroutine

subroutine test_multbymat_sym1(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrhs = 3
 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp
 real(wp), parameter :: x(ncol, nrhs) = 1._wp
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 real(wp) :: y(nrow, nrhs), ycheck(nrow, nrhs)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo
 call crs%setsymmetric()

 y = 1._wp
 call crs%mult(alpha, 'n', x, val, y)

 ycheck = 1._wp
 ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
   + transpose(matcheck(nrow, ncol, ia, ja, a, lvalid .and. ia.lt.ja))&
   , x)

 call check(error, all(abs(y - ycheck) < tol_wp), 'multbymat_sym')

end subroutine

subroutine test_multbymat_gen(error, col, trans, upper)
 character(len=*), intent(in) :: col
 character(len=*), intent(in) :: trans
 character(len=*), intent(in) :: upper
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrhs = 3
 integer, parameter :: nrow = 5
 real(wp), parameter :: alpha = 0.3_wp
 real(wp), parameter :: val = 10000._wp

 integer :: ncol
 real(wp), allocatable :: x(:,:), y(:,:), ycheck(:,:)
 logical :: lvalid(size(ia))
 type(coosparse) :: coo
 type(crssparse) :: crs

 ncol = merge(4, nrow, col == 'y')

 if(upper == 'y')then
  lvalid = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja
 else
  lvalid = ia.le.nrow .and. ja.le.ncol
 endif

 allocate(x(merge(nrow, ncol, trans == 'y'), nrhs), source = 1._wp)
 allocate(y(merge(ncol, nrow, trans == 'y'), nrhs), source = 1._wp)
 allocate(ycheck(merge(ncol, nrow, trans == 'y'), nrhs), source = 1._wp)

 if(col == 'y')then
  if(upper == 'y')then
   coo = coosparse(nrow, n = ncol, lupper = .true., unlog = sparse_unit)
  else
   coo = coosparse(nrow, n = ncol, unlog = sparse_unit)
  endif
 else
  if(upper == 'y')then
   coo = coosparse(nrow, lupper = .true., unlog = sparse_unit)
  else
   coo = coosparse(nrow, unlog = sparse_unit)
  endif
 endif

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 call crs%mult(alpha, merge('t', 'n', trans == 'y'), x, val, y)

 if(trans == 'y')then
  ycheck = ycheck * val + alpha * matmul(&
   transpose(matcheck(nrow, ncol, ia, ja, a, lvalid)) &
   , x)
 else
  ycheck = ycheck * val + alpha * matmul(&
   matcheck(nrow, ncol, ia, ja, a, lvalid) &
   , x)
 endif

 call check(error, all(abs(y - ycheck) < tol_wp)&
                 , 'multbymat_'//col//'_'//trans//'_'//upper)

end subroutine

!NONZERO
subroutine test_nonzero(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4

 integer(int64) :: p(1)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 p = count(ia.le.nrow .and. ja.le.ncol .and. ja.ne.ncol .and. a.ne.0._wp) + nrow

 call check(error, crs%nonzero(), p(1), 'nonzero')

end subroutine

subroutine test_nonzero_sym(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = nrow

 integer(int64) :: p(1)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, lupper = .true., unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a)

 crs = coo

 p = count(ia.le.nrow .and. ja.le.ncol .and. ia.lt.ja .and. a.ne.0._wp) + nrow

 call check(error, crs%nonzero(), p(1), 'nonzero_sym')

end subroutine

!SCALE
subroutine test_scale(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 5
 integer, parameter :: ncol = 4
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 real(wp), parameter :: scalefact = 1000._wp
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a)

 crs = coo

 call crs%scale(scalefact)

 call check(error, all(getmat(crs) == scalefact * matcheck(nrow, ncol, ia, ja, a, lvalid)), 'scale')

end subroutine

!SOLVE using PARDISO VECTOR
subroutine test_solve_vector(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6

 integer :: i
 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !SOLVE
 do i = 1, nrow
  call crs%solve(mat_d(:,i), mat(:,i))
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve vector')

end subroutine

subroutine test_solve_vector_perm(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !SOLVE
 call crs%setpermutation(perm)

 do i = 1, nrow
  call crs%solve(mat_d(:,i), mat(:,i))
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve vector perm')
 if(allocated(error))return

 !SOLVE
 crs = coo

 call crs%setpermutation(permf(nrow))

 do i = 1, nrow
  call crs%solve(mat_d(:,i), mat(:,i))
 enddo

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve vector permf')

end subroutine

subroutine test_solve_array(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6

 integer :: i
 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !SOLVE
 call crs%solve(mat_d, mat)

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve vector')

end subroutine

subroutine test_solve_array_perm(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !SOLVE
 call crs%setpermutation(perm)

 call crs%solve(mat_d, mat)

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve array perm')
 if(allocated(error))return

 !SOLVE
 crs = coo

 call crs%setpermutation(permf(nrow))

 call crs%solve(mat_d, mat)

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve array permf')

end subroutine

#if (_SPAINV==1)
!SOLVE LDLt
subroutine test_solveldlt(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 real(wp) :: mat_d(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, aspsd)

 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 !LDLt
 call crs%setpermutation(perm)
 call crs%getldlt()

 do i = 1, nrow
  call crs%solveldlt(mat_d(:,i), mat(:,i))
 enddo

 !mat_l: expected result
 mat_l = reshape([(merge(1._wp, 0._wp, i/nrow.eq.mod(i,nrow)), i = 0, nrow**2 - 1)], [nrow, nrow])
 where(mat <= tol_wp) mat_l = 0._wp

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve LDLt')
 if(allocated(error))return

 !LDLt
 crs = coo

 call crs%setpermutation(permf(nrow))
 call crs%getldlt()

 do i = 1, nrow
  call crs%solveldlt(mat_d(:,i), mat(:,i))
 enddo

 call check(error, all(abs(mat_d - mat_l) < tol_wp), 'Solve LDLt permf')

end subroutine

!GET SPARSE INVERSE
subroutine test_spainv(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: vect(nrow)
 real(wp) :: mat(nrow, nrow)
 real(wp) :: matinv(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crschol

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2], [aspsd, 2._wp])

 !Cholesky
 crschol= coo
 call crschol%setpermutation(perm)
 call crschol%chol()

 do i = 1, nrow
  vect = 0
  vect(i) = 1
  call crschol%isolve(matinv(:,i), vect) !matinv reference
 enddo

 !SPAINV
 crs = coo

 call getija_crs(crs, iat, jat, at, mat)

 call crs%setpermutation(perm)
 call crs%spainv()

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat_l)

 call check(error, all(abs(pack(mat_l, mat.ne.0) - pack(matinv, mat.ne.0)) < tol_wp), 'spainv')
 if(allocated(error))return

 !SPAINV
 crs = coo

 call crs%setpermutation(permf(nrow))
 call crs%spainv()

 deallocate(iat, jat, at)
 call getija_crs(crs, iat, jat, at, mat_l)

 call check(error, all(abs(pack(mat_l, mat.ne.0) - pack(matinv, mat.ne.0)) < tol_wp), 'spainv_permf')

end subroutine

subroutine test_spainv_failed(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i
 integer, parameter :: nrow = 6
 integer, parameter :: perm(nrow) = [(i, i = nrow, 1, -1)]

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: vect(nrow)
 real(wp) :: matinv(nrow, nrow)
 real(wp) :: mat_l(nrow, nrow)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crschol

 coo = coosparse(nrow, lupper = .true.,  unlog = sparse_unit)
 call coo%setsymmetric()

 call addval(coo, coo%getdim(1), coo%getdim(2), [ia, 2], [ja, 2], [aspsd, 2._wp])

 !Cholesky
 crschol= coo
 call crschol%setpermutation(perm)
 call crschol%chol()

 do i = 1, nrow
  vect = 0
  vect(i) = 1
  call crschol%isolve(matinv(:,i), vect) !matinv reference
 enddo

 !SPAINV
 crs = coo

 call crs%setpermutation(perm)
 call crs%spainv()

 call getija_crs(crs, iat, jat, at, mat_l)

 !this test should failed because matinv contains more non-zero elements than mat_l
 call check(error, all(abs(mat_l - matinv ) < tol_wp), 'should_spainv_failed')

end subroutine
#endif

!SUBMATRIX
subroutine test_submatrix_off_full_full(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 3, colstart = 4, colend = 5
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a, iat, jat, at, mat)

 crs = coo

 crssub = crs%submatrix(rowstart, rowend, colstart, colend)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_off_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_off_dim2')
 if(allocated(error))return

 call check(error, all(getmat(crssub) == mat(rowstart:rowend, colstart:colend)) &
            , 'submatrix_off_full_full')

end subroutine

subroutine test_submatrix_off_full_upper(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i, j

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 3, colstart = 4, colend = 5
 integer, parameter :: subrow = rowend - rowstart + 1
 integer, parameter :: subcol = colend - colstart + 1
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol
 logical, parameter :: lsubval(subrow, subcol) = reshape(merge(.true., .false.&
                        , [((i, j=1, subrow), i = 1, subcol)] .ge.&
                          [((j, j=1, subrow), i = 1, subcol)])&
                        , [subrow, subcol])

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a, iat, jat, at, mat)

 crs = coo

 crssub = crs%submatrix(rowstart, rowend, colstart, colend, lupper = .true.)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_off_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_off_dim2')
 if(allocated(error))return

 call check(error, all(pack(getmat(crssub), lsubval) == pack(&
            mat(rowstart:rowend, colstart:colend), lsubval)) &
            , 'submatrix_off_full_upper')
 if(allocated(error))return

 call check(error, all(pack(getmat(crssub), .not.lsubval) ==  0._wp) &
            , 'submatrix_off_full_upper_0')

end subroutine

subroutine test_submatrix_off_upper_full(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 3, colstart = 4, colend = 5
 integer, parameter :: subrow = rowend - rowstart + 1
 integer, parameter :: subcol = colend - colstart + 1
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a, iat, jat, at, mat)

 crs = coo
 crssub = crs%submatrix(rowstart, rowend, colstart, colend, lupper = .false.)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_off_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_off_dim2')
 if(allocated(error))return

 call check(error, all(getmat(crssub) == &
            mat(rowstart:rowend, colstart:colend)) &
            , 'submatrix_off_upper_full')
 if(allocated(error))return

end subroutine

subroutine test_submatrix_full_full(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 4, colstart = 3, colend = 5
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2),  ia, ja, a, iat, jat, at, mat)

 crs = coo

 crssub = crs%submatrix(rowstart, rowend, colstart, colend)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_dim2')
 if(allocated(error))return

 call check(error, all(getmat(crssub) == mat(rowstart:rowend, colstart:colend)) &
            , 'submatrix_full_full')

end subroutine

subroutine test_submatrix_full_upper(error)
 type(error_type), allocatable, intent(out) :: error

 integer :: i, j

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 4, colstart = 3, colend = 5
 integer, parameter :: subrow = rowend - rowstart + 1
 integer, parameter :: subcol = colend - colstart + 1
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol
 logical, parameter :: lsubval(subrow, subcol) = reshape(merge(.true., .false.&
                        , [((i, j=1, subrow), i = 1, subcol)] .ge.&
                          [((j, j=1, subrow), i = 1, subcol)])&
                        , [subrow, subcol])

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a, iat, jat, at, mat)

 crs = coo

 crssub = crs%submatrix(rowstart, rowend, colstart, colend, lupper = .true.)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_dim2')
 if(allocated(error))return

 call check(error, all(pack(getmat(crssub), lsubval) == pack(&
            mat(rowstart:rowend, colstart:colend), lsubval)) &
            , 'submatrix_full_upper')
 if(allocated(error))return

 call check(error, all(pack(getmat(crssub), .not.lsubval) ==  0._wp) &
            , 'submatrix_full_upper_0')

end subroutine

subroutine test_submatrix_upper_full(error)
 type(error_type), allocatable, intent(out) :: error

 integer, parameter :: nrow = 6
 integer, parameter :: ncol = 5
 integer, parameter :: rowstart = 1, rowend = 4, colstart = 3, colend = 5
 integer, parameter :: subrow = rowend - rowstart + 1
 integer, parameter :: subcol = colend - colstart + 1
 logical, parameter :: lvalid(size(ia)) = ia.le.nrow .and. ja.le.ncol .and. ia.le.ja

 integer, allocatable :: iat(:), jat(:)
 real(wp), allocatable :: at(:)
 real(wp) :: mat(nrow, ncol)
 type(coosparse) :: coo
 type(crssparse) :: crs
 type(crssparse) :: crssub

 coo = coosparse(nrow, n = ncol, lupper = .true.,  unlog = sparse_unit)

 call addval(coo, coo%getdim(1), coo%getdim(2), ia, ja, a, iat, jat, at, mat)

 crs = coo

 crssub = crs%submatrix(rowstart, rowend, colstart, colend, lupper = .false.)

 call check(error, crssub%getdim(1), rowend - rowstart + 1, 'submatrix_dim1')
 if(allocated(error))return

 call check(error, crssub%getdim(2), colend - colstart + 1, 'submatrix_dim2')
 if(allocated(error))return

 call check(error, all(getmat(crssub) == mat(rowstart:rowend, colstart:colend)) &
            , 'submatrix_upper_full')

end subroutine

!INTERNAL
subroutine getija_crs(crs, iat, jat, at, mat)
 type(crssparse), intent(inout) :: crs
 integer, allocatable , intent(out), optional :: iat(:), jat(:)
 real(wp), allocatable , intent(out), optional :: at(:)
 real(wp), intent(out), optional :: mat(:,:)

 integer :: i, j
 integer :: nrow, ncol
 real(wp) :: val

 nrow = crs%getdim(1)
 ncol = crs%getdim(2)

 if(present(mat))then
  if(nrow.ne.size(mat,1) .or. ncol.ne.size(mat,2))return
 endif

 allocate(iat(0), jat(0), at(0))
 do i = 1, nrow
  do j = 1, ncol
   val = crs%get(i, j)
   if(present(mat))then
    if(i.le.nrow.and.j.le.ncol)mat(i, j) = val
   endif
   if (val .ne. 0._wp) then
    iat = [iat, i]
    jat = [jat, j]
    at = [at, val]
   endif
  enddo
 enddo

end subroutine

pure function permf(nrow) result(perm)
 integer, intent(in) :: nrow
 integer :: perm(nrow)

 integer :: i

 perm = [(i, i = nrow, nrow/2 + 1, -1), (i, i = 1, nrow/2)]

end function

end module


program test_ordering
   use iso_fortran_env
   use fsparse
   implicit none
   integer(int32) :: x=123456789, y=362436069, z=521288629, w=88675123
   integer(int32) :: i,j,imax32,thr,seed,info
   integer(int32) :: k,n
   integer(int64) :: nnz,cnnz,nfull
   real(real64) :: ratio,btime,etime
   integer(int32),allocatable :: ia(:)
   integer(int32),allocatable :: ja(:)
   real(real64),allocatable :: a(:)
   integer(int32) :: ordalg

   integer(int32) :: gsz,nthr,msglev
   integer(int64) :: t1,t2,trate
   real(real64) :: options(0:128),dble_null

#if defined(USE_METIS_64) || defined(USE_MTMETIS_64)
   type(sparse_graph_64) :: graph
   integer(int64) :: neq
   integer(int64),allocatable :: perm(:),iperm(:)
#else
   type(sparse_graph_32) :: graph
   integer(int32) :: neq
   integer(int32),allocatable :: perm(:),iperm(:)
#endif

   ! parameters
   call get_param(n,nnz,nthr,seed)
   neq = n
   nfull = n*(n+1)/2
   ratio = dble(nnz)/dble(nfull-neq)
   imax32 = huge(imax32)
   thr = int(imax32*ratio*1.5)
   msglev = 1
   x = x + seed
   y = y + seed
   z = z + seed
   w = w + seed

   print '(A,I14)'  ,'neq          =',n
   print '(A,I14)'  ,'nnz          =',nnz
   print '(A,I14)'  ,'full elements=',nfull
   print '(A,F14.6)','sparse ratio =',ratio
   print '(A,I14)'  ,'rng threshold=',thr
   print '(A,I14)'  ,'nthr         =',nthr
   print '(A,4I14)' ,'seed         =',x,y,z,w

   ! generate a matrix
   print *,'making a sparse matrix'
   allocate(ia(n+1),ja(nnz),a(nnz))
   ia = 0
   ja = 0
   a = 0.0
   ia(1) = 1
   k = 0
   call cpu_time(btime)
   call generate_sparse_matrix(n,nnz,ia,ja,a)
   print '(A,I8,2(A,I12))','column',n,'; nnz=',ia(n+1)-1,'; total nnz=',nnz

   ! start ordering
   allocate(perm(neq),iperm(neq))
   call system_clock(t1)
   call make_sparse_graph(n,ia,ja,graph)
   call system_clock(t2,trate)
   print *,'adjncy allocated = ',size(graph%adjncy), 'filled = ',count(graph%adjncy>0)
   print *,'graph elapsed = ',dble(t2-t1)/trate

   ! AMD
   print '(A,X,I0)','AMD',kind(perm)
   call system_clock(t1)
   call ordering_amd(graph,perm,iperm)
   call system_clock(t2,trate)
   print *,'ordering elapsed = ',dble(t2-t1)/trate
   print *,'checking perm and iperm'
   call check_permutation(neq,perm,iperm)

   ! AMDBAR
   print '(A,X,I0)','AMD BAR',kind(perm)
   call system_clock(t1)
   call ordering_amd(graph,perm,iperm, use_amdbar=.true.)
   call system_clock(t2,trate)
   print *,'ordering elapsed = ',dble(t2-t1)/trate
   print *,'checking perm and iperm'
   call check_permutation(neq,perm,iperm)

   ! METIS 5
#if defined(USE_METIS_32) || defined(USE_METIS_64)
   print '(A,X,I0)','METIS5',kind(perm)
   call system_clock(t1)
   call ordering_metis(graph,perm,iperm)
   call system_clock(t2,trate)
   print *,'ordering elapsed = ',dble(t2-t1)/trate
   print *,'checking perm and iperm'
   call check_permutation(neq,perm,iperm)
#endif

   ! MTMETIS
#if defined(USE_MTMETIS_32) || defined(USE_MTMETIS_64)
   print '(A,X,I0)','MT-METIS',kind(perm)
   call system_clock(t1)
   call ordering_mtmetis(graph,nthr,perm,iperm)
   call system_clock(t2,trate)
   print *,'ordering elapsed = ',dble(t2-t1)/trate
   print *,'checking perm and iperm'
   call check_permutation(neq,perm,iperm)
#endif

   ! MTMETIS
#if defined(USE_MKL_PARDISO_32)
   print '(A,X,I0)','MKL-PARDISO',kind(perm)
   call system_clock(t1)
   call ordering_mkl_pardiso(n,ia,ja,perm,iperm,msglev)
   call system_clock(t2,trate)
   print *,'ordering elapsed = ',dble(t2-t1)/trate
   print *,'checking perm and iperm'
   call check_permutation(neq,perm,iperm)
#endif

   print *,'done'

contains

! generate sparse matrix
subroutine generate_sparse_matrix(n,nnz,ia,ja,a)
   integer,intent(in) :: n
   integer(int64),intent(in) :: nnz
   integer,intent(inout) :: ia(:),ja(:)
   real(real64),intent(inout) :: a(:)
   integer :: k,r1,r2,i,j,kk,cnt,nnz4
   integer,allocatable :: row(:),col(:)
   allocate(row(nnz),col(nnz))
   ! reserved for diagonals
   do k=1,n
      row(k)=k
      col(k)=k
   end do
   do k=n+1,nnz
      ! off-diagonals
      ! upper A[i,j] (i<j)
      r1 = mod(genrand31(),n)+1
      r2 = mod(genrand31(),n)+1
      row(k) = min(r1,r2)
      col(k) = max(r1,r2)
   end do
   nnz4 = nnz
   call iqsort(1,nnz4,row,col)
   ! make ija
   ia(1) = 1
   cnt = 1
   do i=1,n
      kk = 0
      j = 0
      do while(cnt<=nnz)
         if(row(cnt)==i) then
            if(col(cnt)>j) then
               j = col(cnt)
               ja(ia(i)+kk) = j
               kk = kk + 1
            end if
            cnt = cnt + 1
         else
            ia(i+1) = ia(i)+kk
            exit
         end if
      end do
   end do
   ia(n+1) = ia(n)+kk
   do i=1,n
      do k=ia(i),ia(i+1)-1
         j = ja(k)
         if(i==j) then
            a(k) = dble(n)
         else
            a(k) = -1.0
         end if
      end do
   end do
   deallocate(row,col)
end subroutine generate_sparse_matrix

subroutine iqsort(top,bottom,key,val)
   integer,intent(in)    :: top,bottom
   integer,intent(inout) :: key(:),val(:)
   integer,parameter :: thr=10, ss=64
   integer :: i,j,left,right,p, x,t
   integer :: lstack(1:ss),rstack(1:ss)
   left=top
   right=bottom
   p=1
   do
      if(right-left <= thr) then
         if(p==1) exit
         p=p-1
         left =lstack(p)
         right=rstack(p)
      end if
      x=key((left+right)/2)
      i=left
      j=right
      do
         do while(key(i) < x)
            i=i+1
         end do
         do while(x < key(j))
            j=j-1
         end do
         if(i >= j) exit
         ! swap
         t=key(i); key(i)=key(j); key(j)=t
         t=val(i); val(i)=val(j); val(j)=t
         ! next
         i=i+1;    j=j-1
      end do
      if(i-left > right-j) then
         if(i-left > thr) then
            lstack(p)=left
            rstack(p)=i-1
            p=p+1
         end if
         left=j+1
      else
         if(right-j > thr) then
            lstack(p)=j+1
            rstack(p)=right
            p=p+1
         end if
         right=i-1
      end if
   end do
   call iinssort(top,bottom,key,val)
end subroutine iqsort

subroutine iinssort(top,bottom,key,val)
   integer,intent(in)    :: top,bottom
   integer,intent(inout) :: key(:),val(:)
   integer :: i,j,lb,ub,x,y
   lb=top
   ub=bottom
   do i=lb+1,ub
      x=key(i)
      y=val(i)
      j=i-1
      do while(j >= lb)
         if(key(j) > x) then
            key(j+1)=key(j)
            val(j+1)=val(j)
         else
            exit
         end if
         j=j-1
      end do
      key(j+1)=x
      val(j+1)=y
   end do
end subroutine iinssort

! xorshift
subroutine setseed(p,q,r,s)
   integer,intent(in) :: p,q,r,s
   x = p
   y = q
   z = r
   w = s
   if(p+q+r+s <= 0) then
      print '(A)','ERROR: x+y+z+w must be >0.'
      stop
   end if
end subroutine setseed
function genrand31() result(r)
   integer :: r,t
   t = ieor(x,ishft(x,-11))
   x = y
   y = z
   z = w
   w = ieor( ieor(w,ishft(w,19)), ieor(t,ishft(t,8)) )
   r = abs(w)
end function genrand31

subroutine get_param(n,nnz,nthr,seed)
   integer(int32),intent(inout) :: n
   integer(int64),intent(inout) :: nnz
   integer(int32),intent(inout) :: nthr
   integer(int32),intent(inout) :: seed
   integer :: argc,io
   character(len=32) :: argv
   n = 1000000
   nnz = 1500000_int64
   nthr = 1
   seed = 0
   argc = command_argument_count()
   if(argc<=1) then
      print '(A)','usage: test_ordering neq nnz [nthr] [seed]'
      stop
   end if
   call get_command_argument(1,argv)
   read(argv,*,iostat=io) n
   if(io/=0) then
      print *,'Invalid neq'
      stop
   end if
   call get_command_argument(2,argv)
   read(argv,*,iostat=io) nnz
   if(io/=0) then
      print *,'Invalid nnz'
      stop
   end if
   if(n>nnz) then
      print *,'nnz smaller than n'
      stop
   end if

   if(argc>2) then
      call get_command_argument(3,argv)
      read(argv,*,iostat=io) nthr
      if(io/=0) then
         print *,'Invalid nthr'
         stop
      end if
   end if
   if(argc>3) then
      call get_command_argument(4,argv)
      read(argv,*,iostat=io) seed
      if(io/=0) then
         print *,'Invalid seed'
         stop
      end if
   end if
end subroutine get_param

end program test_ordering


      MODULE  CONSTANT
        USE PREC
        implicit none
        real(dp), parameter :: b2a = 0.52917721092d0
        real(dp), parameter :: pi = 4.d0*DATAN(1.d0)
        real(dp), parameter :: invsqrt2pi = 1.d0/sqrt(2.0d0*pi)
        real(dp), parameter :: invsqrtpi = 1.d0/sqrt(pi)
        real(dp), parameter :: invpi = 1.d0/pi
        real(dp), parameter :: ev2h = 1.d0/27.21138505d0

      END MODULE


/* Examples for testing */

 "hello";

unit;

timesfloat 2.0 3.14159;

let x=true in x;

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);

{x=true, y=false};
{x=true, y=false}.x;
{true, false};
{true, false}.1;

lambda x:<a:Bool,b:Bool>. x;

Counter = Rec P. {get:Nat, inc:Unit->P};
p =
let create =
  fix
    (lambda cr: {x:Nat}->Counter.
      lambda s: {x:Nat}.
        fold [Counter]
          {get = s.x,
           inc = lambda _:Unit. cr {x=succ(s.x)}})
in
  create {x=0};
p1 = (unfold [Counter] p).inc unit;
(unfold [Counter] p1).get;

T = Nat->Nat;
lambda f:T. lambda x:Nat. f (f x);

lambda x:A. x;


program tstLAPACK

integer,parameter      :: n=3
real,dimension(n*n)    :: a
real,dimension(n)      :: b
integer,dimension(n)   :: ipiv
integer                :: i,info,nrhs,lda,ldb
real                   :: expected

!set up dumb system
a=(/  1,0,0,  &
      0,2,0,  &
      0,0,3  /)

b=(/   2,  &
       4,  &
       6  /)

!solution is 2,2,2

!calculate solution of a*x=b and put into b
nrhs=1
lda=n
ldb=n
call sgesv( n, nrhs, a, lda, ipiv, b, ldb, info )

if( info/=0 )then
    write(*,*)'LAPACK::sgesv failed with info=',info,'!'
    stop
end if

do i=1,n
    expected = 2
    if( abs( b(i)/expected - 1 )>1e-4 )then
        write(*,*)'error matching element i=',i,' expected=',expected,' received=',b(i)
        stop
    end if
end do

end program