SUBROUTINE CmpDMFTrans(DMFTrans, DMFTU, alml, ri_mat, projector, cfX, L, iorb1, cix_orb, nindo, iso, nemin, nbands, nind, maxdim2, icix, idt, icase, lcase, lmax2, nume, nrf, nrfmax, norbitals)
  ! The DMFT transformation is created, which transforms between Kohn-Sham basis and DMFT basis.
  ! It is created by :
  ! DMFTransform(i,j,L,M) = <Y_{L}(r_1)|psi_{ki}(r_1)><psi_{kj}(r_2)|Y_{M}(r_2)>*delta(r_1-r_2)
  ! Where <|> stands for the integral over space angles of r_1 and r_2 only,
  ! while delta(r_1-r_2) is delta function in radial distance only.
  !
  ! The transformation has the following important properties:
  !
  ! \sum_i DMFTrans(i,i,L1,L2) = delta(L1,L2)
  !
  ! \sum_L DMFTrans(i,j,L,L) = delta(i,j) . Be careful! For this to be walid, one needs to sum over all L to high cutoff.
  !                                         Something we never really need to do.
  !
  ! sum_{ij} DMFTrans(i,j,L1,L2) * DMFTrans(j,i,L2p,L1p) = delta(L1,L1p)*delta(L2,L2p)
  ! which makes shure that a quantity G_{LL'} when transformed to G_{ij} and back to G_{LL'} takes the same form
  !
  USE p_project,ONLY: rix_mat, al_ucase, al_interstitial
  IMPLICIT NONE
  COMPLEX*16, intent(out) :: DMFTrans(nbands,nbands,maxdim2,maxdim2)
  COMPLEX*16, intent(out) :: DMFTU(nbands,maxdim2,norbitals)
  COMPLEX*16, intent(in)  :: alml(0:lmax2,2*lmax2+1,nume,nrf,2)
  REAL*8,     intent(in)  :: ri_mat(nrf,nrf,0:lmax2,2)
  COMPLEX*16, intent(in)  :: cfX(maxdim2,maxdim2,norbitals,norbitals)
  INTEGER,    intent(in)  :: L, iorb1, cix_orb(norbitals), nindo(norbitals), iso, nemin, nbands, nind, icix, idt
  INTEGER,    intent(in)  :: lmax2, nume, nrf, maxdim2, nrfmax, norbitals
  INTEGER,    intent(in)  :: projector, icase, lcase
  ! locals
  INTEGER :: N1, num1, num2, is1, m1, lms1, ind1, is2, m2, lms2, ind2, irf1, irf2, it, nind1, nind2, iorb2
  COMPLEX*16 :: csum, cc, corc, sm1, sm2, ff
  REAL*8     :: fct
  COMPLEX*16, allocatable :: Rx(:,:), cft(:,:), URx(:,:), tmp(:,:)
  INTEGER, allocatable    :: non_zero(:,:,:), all_non_zero(:)
  REAL*8 :: small
  !COMPLEX*16 :: tuu, tud, tdu, tdd
  !COMPLEX*16, allocatable :: Uu(:,:), Ud(:,:)
  INTEGER :: iind

  small = 1e-6   ! cutoff for ri_mat
  N1=2*L+1

  ALLOCATE( cft(maxdim2,maxdim2) )
  allocate( non_zero(2,nrf**2,iso), all_non_zero(iso) )
  ALLOCATE( tmp(nbands,maxdim2) )
  ! for optimization purposes only ! Many terms in ri_mat are zero, because u*dot{u}=0
  do is1=1,iso
     it=1
     do irf1=1,nrfmax
        do irf2=1,nrfmax
           if (abs(ri_mat(irf1,irf2,L,is1)).gt.small) then
              non_zero(1,it,is1) = irf1
              non_zero(2,it,is1) = irf2
              it = it+1
           endif
        enddo
     enddo
     all_non_zero(is1)=it-1
  enddo

  !$OMP PARALLEL DO SHARED(DMFTrans) PRIVATE(Rx,num1,num2,is1,m1,lms1,ind1,is2,m2,lms2,ind2,csum,fct,it,irf1,irf2) SCHEDULE(STATIC)
  do num1=1,nbands      !nemin,nemax     ! over bands
     allocate( Rx(nind,nind) )
     do num2=1,nbands   !nemin,nemax     ! over bands
        if (icix.eq.0 .and. num1.ne.num2) CYCLE  ! for non correlated bands, we need only band1=band2 transformation
        do is1=1,iso            ! over spin-1
           do m1=-L,L           ! over m-1
              lms1=L+1+m1
              ind1=L+1+idt*m1+N1*(is1-1)
              is2=is1
              do m2=-L,L     ! over m-2
                 lms2=L+1+m2
                 ind2=L+1+idt*m2+N1*(is2-1)
                 csum=0
                 fct = idt**(m1+m2)
                 do it=1,all_non_zero(is1) ! This optimization is because ri_mat is zero for most of components
                    irf1 = non_zero(1,it,is1)
                    irf2 = non_zero(2,it,is1)
                    if (idt.gt.0) then
                       csum = csum + alml(L,lms1,num1+nemin-1,irf1,is1)*conjg(alml(L,lms2,num2+nemin-1,irf2,is2))*(ri_mat(irf1,irf2,L,is1)*fct)
                    else
                       csum = csum + conjg(alml(L,lms1,num1+nemin-1,irf1,is1))*alml(L,lms2,num2+nemin-1,irf2,is2)*(ri_mat(irf1,irf2,L,is1)*fct)
                    endif
                 enddo
                 Rx(ind1,ind2) = csum
              enddo
           enddo
        enddo
        DMFTrans(num1,num2,:nind,:nind) = Rx
     enddo
     deallocate( Rx )
  enddo
  !$OMP END PARALLEL DO

  deallocate( non_zero, all_non_zero )

  if (icix.gt.0) then
     allocate( URx(nbands,nind) )

     if (abs(projector).eq.1) then
        ! For correlated orbitals, we will also create transformation matrix U, such that P(LL'ij)=U^\dagger*U

        !$OMP PARALLEL DO SHARED(URx) PRIVATE(num1,is1,m1,lms1,ind1,cc,irf1) SCHEDULE(STATIC)
        do num1=1,nbands      !nemin,nemax     ! over bands
           do is1=1,iso            ! over spin-1
              do m1=-L,L           ! over m-1
                 lms1=L+1+m1
                 ind1=L+1+idt*m1+N1*(is1-1)
                 cc=0
                 do irf1=1,nrfmax
                    cc = cc + alml(L,lms1,num1+nemin-1,irf1,is1)*ri_mat(irf1,1,L,is1)*(idt)**m1
                 enddo
                 if (idt.gt.0) then
                    URx(num1,ind1) = cc
                 else
                    URx(num1,ind1) = conjg(cc)
                 endif
              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO
     elseif (abs(projector).eq.2 .or. abs(projector).eq.4) then
        ! For correlated orbitals, we will also create transformation matrix U, such that P(LL'ij)=U^\dagger*U

        !$OMP PARALLEL DO SHARED(URx) PRIVATE(num1,is1,m1,lms1,ind1,cc,sm1,sm2,irf1,irf2,ff) SCHEDULE(STATIC)
        do num1=1,nbands      !nemin,nemax     ! over bands
           do is1=1,iso            ! over spin-1
              do m1=-L,L           ! over m-1
                 lms1=L+1+m1
                 ind1=L+1+idt*m1+N1*(is1-1)
                 cc=0
                 sm1=0
                 sm2=0
                 do irf1=1,nrfmax
                    do irf2=1,nrfmax
                       ff = alml(L,lms1,num1+nemin-1,irf1,is1)*conjg(alml(L,lms1,num1+nemin-1,irf2,is1))
                       sm1 = sm1 + ff * ri_mat(irf1,irf2,L,is1)
                       sm2 = sm2 + ff * ri_mat(irf1,1,L,is1) * ri_mat(1,irf2,L,is1)
                    enddo
                    cc = cc + alml(L,lms1,num1+nemin-1,irf1,is1)*ri_mat(irf1,1,L,is1)*(idt)**m1
                 enddo
                 cc = cc * sqrt(abs(sm1/sm2))
                 if (idt.gt.0) then
                    URx(num1,ind1) = cc
                 else
                    URx(num1,ind1) = conjg(cc)
                 endif
              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO
     elseif (abs(projector).eq.3) then
        ! For correlated orbitals, we will also create transformation matrix U, such that P(LL'ij)=U^\dagger*U

        !$OMP PARALLEL DO SHARED(URx) PRIVATE(num1,is1,m1,lms1,ind1,cc,corc,irf1,irf2) SCHEDULE(STATIC)
        do num1=1,nbands      !nemin,nemax     ! over bands
           do is1=1,iso            ! over spin-1
              do m1=-L,L           ! over m-1
                 lms1=L+1+m1
                 ind1=L+1+idt*m1+N1*(is1-1)
                 irf1 = 1
                 cc = alml(L,lms1,num1+nemin-1,irf1,is1)*sqrt(ri_mat(irf1,irf1,L,is1))*(idt)**m1
                 ! Adding correction due to \cdot{u} and local orbitals
                 ! The results is  A(i,L,irf=1)*sqrt(o(L)) * sqrt( 1 + \sum_{irf>1} |A(i,L,irf)|^2*o(L,irf))
                 if ( abs(cc)>1e-6 ) then
                    corc = 0
                    do irf1=1,nrfmax
                       do irf2=1,nrfmax
                          if (irf1.eq.1 .and. irf2.eq.1) cycle
                          corc = corc + alml(L,lms1,num1+nemin-1,irf1,is1)*conjg(alml(L,lms1,num1+nemin-1,irf2,is1))*ri_mat(irf1,irf2,L,is1)
                       enddo
                    enddo
                    cc = cc*sqrt(1 + abs(corc)/abs(cc)**2)
                 endif
                 if (idt.gt.0) then
                    URx(num1,ind1) = cc
                 else
                    URx(num1,ind1) = conjg(cc)
                 endif
              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO
     elseif (abs(projector).eq.5) then
        iind = al_ucase(icase,lcase)
        !$OMP PARALLEL DO SHARED(URx,rix_mat) PRIVATE(num1,is1,m1,lms1,ind1,cc,irf1) SCHEDULE(STATIC)
        do num1=1,nbands
           do is1=1,iso
              do m1=-L,L
                 lms1=L+1+m1
                 ind1=L+1+idt*m1+N1*(is1-1)
                 cc=0
                 do irf1=1,nrfmax
                    cc = cc + alml(L,lms1,num1+nemin-1,irf1,is1)*rix_mat(irf1,iind)*(idt)**m1
                 enddo
                 !!! New
                 cc = cc + al_interstitial(lms1,num1,is1,lcase)*(idt)**m1
                 !!! New
                 if (idt.gt.0) then
                    URx(num1,ind1) = cc
                 else
                    URx(num1,ind1) = conjg(cc)
                 endif
              enddo
           enddo
        enddo
        !$OMP END PARALLEL DO
     else
        print *, 'Only projector=[1,2,3,4,5] is allowed!'
        stop
     endif

     nind1 = (2*L+1)*iso
     !if (iso.eq.2) then
     !   no1 = nind1/iso
     !   ALLOCATE( Uu(nbands,no1), Ud(nbands,no1))
     !   tuu = Rspin(1,1,iorb1)
     !   tud = Rspin(1,2,iorb1)
     !   tdu = Rspin(2,1,iorb1)
     !   tdd = Rspin(2,2,iorb1)
     !   Uu(:,:) = URx(:,1:no1)
     !   Ud(:,:) = URx(:,no1+1:2*no1)
     !   URx(:,1:no1)       = Uu*tuu + Ud*tdu
     !   URx(:,no1+1:2*no1) = Uu*tud + Ud*tdd
     !   DEALLOCATE( Uu, Ud )
     !endif

     DO iorb2=1,norbitals
        if ( cix_orb(iorb2).NE. icix ) CYCLE
        nind2 = nindo(iorb2)
        call zgemm('N','C', nbands, nind2, nind1, (1.d0,0.d0), URx,nbands, cfX(:,:,iorb2,iorb1),maxdim2, (0.d0,0.d0), tmp,nbands)
        DMFTU(:,:nind2,iorb2) = DMFTU(:,:nind2,iorb2) + conjg(tmp(:,:nind2))
     ENDDO

     deallocate(URx)
  endif

  deallocate( cft )
  deallocate( tmp )
end SUBROUTINE CmpDMFTrans


c\BeginDoc
c
c\Name: csortc
c
c\Description:
c  Sorts the Complex array in X into the order
c  specified by WHICH and optionally applies the permutation to the
c  Real  array Y.
c
c\Usage:
c  call csortc
c     ( WHICH, APPLY, N, X, Y )
c
c\Arguments
c  WHICH   Character*2.  (Input)
c          'LM' -> sort X into increasing order of magnitude.
c          'SM' -> sort X into decreasing order of magnitude.
c          'LR' -> sort X with real(X) in increasing algebraic order
c          'SR' -> sort X with real(X) in decreasing algebraic order
c          'LI' -> sort X with imag(X) in increasing algebraic order
c          'SI' -> sort X with imag(X) in decreasing algebraic order
c
c  APPLY   Logical.  (Input)
c          APPLY = .TRUE.  -> apply the sorted order to array Y.
c          APPLY = .FALSE. -> do not apply the sorted order to array Y.
c
c  N       Integer.  (INPUT)
c          Size of the arrays.
c
c  X       Complex array of length N.  (INPUT/OUTPUT)
c          This is the array to be sorted.
c
c  Y       Complex array of length N.  (INPUT/OUTPUT)
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Routines called:
c     wslapy2  LAPACK routine to compute sqrt(x**2+y**2) carefully.
c
c\Author
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Dept. of Computational &     Houston, Texas
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c     Adapted from the sort routine in LANSO.
c
c\SCCS Information: @(#)
c FILE: sortc.F   SID: 2.2   DATE OF SID: 4/20/96   RELEASE: 2
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine csortc (which, apply, n, x, y)
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      character*2 which
      logical    apply
      integer    n
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Complex
     &           x(0:n-1), y(0:n-1)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer    i, igap, j
      Complex
     &           temp
      Real
     &           temp1, temp2
c
c     %--------------------%
c     | External functions |
c     %--------------------%
c
      Real
     &           wslapy2
c
c     %--------------------%
c     | Intrinsic Functions |
c     %--------------------%
       Intrinsic
     &           real, aimag
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      igap = n / 2
c
      if (which .eq. 'LM') then
c
c        %--------------------------------------------%
c        | Sort X into increasing order of magnitude. |
c        %--------------------------------------------%
c
   10    continue
         if (igap .eq. 0) go to 9000
c
         do 30 i = igap, n-1
            j = i-igap
   20       continue
c
            if (j.lt.0) go to 30
c
            temp1 = wslapy2(real(x(j)),aimag(x(j)))
            temp2 = wslapy2(real(x(j+igap)),aimag(x(j+igap)))
c
            if (temp1.gt.temp2) then
                temp = x(j)
                x(j) = x(j+igap)
                x(j+igap) = temp
c
                if (apply) then
                    temp = y(j)
                    y(j) = y(j+igap)
                    y(j+igap) = temp
                end if
            else
                go to 30
            end if
            j = j-igap
            go to 20
   30    continue
         igap = igap / 2
         go to 10
c
      else if (which .eq. 'SM') then
c
c        %--------------------------------------------%
c        | Sort X into decreasing order of magnitude. |
c        %--------------------------------------------%
c
   40    continue
         if (igap .eq. 0) go to 9000
c
         do 60 i = igap, n-1
            j = i-igap
   50       continue
c
            if (j .lt. 0) go to 60
c
            temp1 = wslapy2(real(x(j)),aimag(x(j)))
            temp2 = wslapy2(real(x(j+igap)),aimag(x(j+igap)))
c
            if (temp1.lt.temp2) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
c
               if (apply) then
                  temp = y(j)
                  y(j) = y(j+igap)
                  y(j+igap) = temp
               end if
            else
               go to 60
            endif
            j = j-igap
            go to 50
   60    continue
         igap = igap / 2
         go to 40
c
      else if (which .eq. 'LR') then
c
c        %------------------------------------------------%
c        | Sort XREAL into increasing order of algebraic. |
c        %------------------------------------------------%
c
   70    continue
         if (igap .eq. 0) go to 9000
c
         do 90 i = igap, n-1
            j = i-igap
   80       continue
c
            if (j.lt.0) go to 90
c
            if (real(x(j)).gt.real(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
c
               if (apply) then
                  temp = y(j)
                  y(j) = y(j+igap)
                  y(j+igap) = temp
               end if
            else
               go to 90
            endif
            j = j-igap
            go to 80
   90    continue
         igap = igap / 2
         go to 70
c
      else if (which .eq. 'SR') then
c
c        %------------------------------------------------%
c        | Sort XREAL into decreasing order of algebraic. |
c        %------------------------------------------------%
c
  100    continue
         if (igap .eq. 0) go to 9000
         do 120 i = igap, n-1
            j = i-igap
  110       continue
c
            if (j.lt.0) go to 120
c
            if (real(x(j)).lt.real(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
c
               if (apply) then
                  temp = y(j)
                  y(j) = y(j+igap)
                  y(j+igap) = temp
               end if
            else
               go to 120
            endif
            j = j-igap
            go to 110
  120    continue
         igap = igap / 2
         go to 100
c
      else if (which .eq. 'LI') then
c
c        %--------------------------------------------%
c        | Sort XIMAG into increasing algebraic order |
c        %--------------------------------------------%
c
  130    continue
         if (igap .eq. 0) go to 9000
         do 150 i = igap, n-1
            j = i-igap
  140       continue
c
            if (j.lt.0) go to 150
c
            if (aimag(x(j)).gt.aimag(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
c
               if (apply) then
                  temp = y(j)
                  y(j) = y(j+igap)
                  y(j+igap) = temp
               end if
            else
               go to 150
            endif
            j = j-igap
            go to 140
  150    continue
         igap = igap / 2
         go to 130
c
      else if (which .eq. 'SI') then
c
c        %---------------------------------------------%
c        | Sort XIMAG into decreasing algebraic order  |
c        %---------------------------------------------%
c
  160    continue
         if (igap .eq. 0) go to 9000
         do 180 i = igap, n-1
            j = i-igap
  170       continue
c
            if (j.lt.0) go to 180
c
            if (aimag(x(j)).lt.aimag(x(j+igap))) then
               temp = x(j)
               x(j) = x(j+igap)
               x(j+igap) = temp
c
               if (apply) then
                  temp = y(j)
                  y(j) = y(j+igap)
                  y(j+igap) = temp
               end if
            else
               go to 180
            endif
            j = j-igap
            go to 170
  180    continue
         igap = igap / 2
         go to 160
      end if
c
 9000 continue
      return
c
c     %---------------%
c     | End of csortc |
c     %---------------%
c
      end


!     Copyright 1998-2019 Lawrence Livermore National Security, LLC and other
!     HYPRE Project Developers. See the top-level COPYRIGHT file for details.
!
!     SPDX-License-Identifier: (Apache-2.0 OR MIT)

! **********************************************************************
! * Eispack functions for computing eigenvalues and eigenvectors
! **********************************************************************

! **********************************************************************
!     this subroutine calls the recommended sequence of
!     subroutines from the eigensystem subroutine package (eispack)
!     to find the eigenvalues and eigenvectors (if desired)
!     of a real symmetric matrix.
!
!     on input
!
!        nm  must be set to the row dimension of the two-dimensional
!        array parameters as declared in the calling program
!        dimension statement.
!
!        n  is the order of the matrix  a.
!
!        a  contains the real symmetric matrix.
!
!        matz  is an integer variable set equal to zero if
!        only eigenvalues are desired.  otherwise it is set to
!        any non-zero integer for both eigenvalues and eigenvectors.
!
!     on output
!
!        w  contains the eigenvalues in ascending order.
!
!        z  contains the eigenvectors if matz is not zero.
!
!        ierr  is an integer output variable set equal to an error
!           completion code described in the documentation for tqlrat
!           and tql2.  the normal completion code is zero.
!
!        fv1  and  fv2  are temporary storage arrays.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
! ----------------------------------------------------------------------
!
      subroutine mli_computeSpectrum(nm,n,a,w,matz,z,fv1,fv2,ierr)
      integer n,nm,ierr,matz
      double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
!
   10 if (matz .ne. 0) go to 20
!     .......... find eigenvalues only ..........
      call  mli_tred1(nm,n,a,w,fv1,fv2)
!  tqlrat encounters catastrophic underflow on the Vax
!     call  tqlrat(n,w,fv2,ierr)
      call  mli_tql1(n,w,fv1,ierr)
      go to 50
!     .......... find both eigenvalues and eigenvectors ..........
   20 call  mli_tred2(nm,n,a,w,fv1,z)
      call  mli_tql2(nm,n,w,fv1,z,ierr)
   50 return
      end

! **********************************************************************
!
!     this subroutine is a translation of the algol procedure tql1,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues of a symmetric
!     tridiagonal matrix by the ql method.
!
!     on input
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!      on output
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct and
!          ordered for indices 1,2,...ierr-1, but may not be
!          the smallest eigenvalues.
!
!        e has been destroyed.
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     calls pythag for  dsqrt(a*a + b*b) .
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
! ----------------------------------------------------------------------
!
      subroutine mli_tql1(n,d,e,ierr)
      integer i,j,l,m,n,ii,l1,l2,mml,ierr
      double precision d(n),e(n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2
      double precision mli_pythag
      double precision mli_dsign

      ierr = 0
      if (n .eq. 1) go to 1001
!
      do 100 i = 2, n
      e(i-1) = e(i)
  100 continue
!
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
!
      do 290 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
!     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
!     .......... e(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
  110    continue
!
  120    if (m .eq. l) go to 210
  130    if (j .eq. 30) go to 1000
         j = j + 1
!     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = mli_pythag(p,1.0d0)

         if (p . ge. 0.e0) then
            mli_dsign = dabs(r)
         end if

         if (p .lt. 0.e0) then
            mli_dsign = -dabs(r)
         end if

         d(l) = e(l) / (p + mli_dsign)
         d(l1) = e(l) * (p + mli_dsign)
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
!
         do 140 i = l2, n
         d(i) = d(i) - h
  140    continue
!
  145    f = f + h
!     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = mli_pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
  200    continue
!
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  210    p = d(l) + f
!     .......... order eigenvalues ..........
         if (l .eq. 1) go to 250
!     .......... for i=l step -1 until 2 do -- ..........
         do 230 ii = 2, l
            i = l + 2 - ii
            if (p .ge. d(i-1)) go to 270
            d(i) = d(i-1)
  230    continue
!
  250    i = 1
  270    d(i) = p
  290 continue
!
      go to 1001
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end

! **********************************************************************
!
!     this subroutine is a translation of the algol procedure tql2,
!     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
!     wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
!
!     this subroutine finds the eigenvalues and eigenvectors
!     of a symmetric tridiagonal matrix by the ql method.
!     the eigenvectors of a full symmetric matrix can also
!     be found if  tred2  has been used to reduce this
!     full matrix to tridiagonal form.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        d contains the diagonal elements of the input matrix.
!
!        e contains the subdiagonal elements of the input matrix
!          in its last n-1 positions.  e(1) is arbitrary.
!
!        z contains the transformation matrix produced in the
!          reduction by  tred2, if performed.  if the eigenvectors
!          of the tridiagonal matrix are desired, z must contain
!          the identity matrix.
!
!      on output
!
!        d contains the eigenvalues in ascending order.  if an
!          error exit is made, the eigenvalues are correct but
!          unordered for indices 1,2,...,ierr-1.
!
!        e has been destroyed.
!
!        z contains orthonormal eigenvectors of the symmetric
!          tridiagonal (or full) matrix.  if an error exit is made,
!          z contains the eigenvectors associated with the stored
!          eigenvalues.
!
!        ierr is set to
!          zero       for normal return,
!          j          if the j-th eigenvalue has not been
!                     determined after 30 iterations.
!
!     calls pythag for  dsqrt(a*a + b*b) .
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
! ----------------------------------------------------------------------
!
      subroutine mli_tql2(nm,n,d,e,z,ierr)
      integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
      double precision mli_dsign
      double precision d(n),e(n),z(nm,n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2
      double precision mli_pythag
!
      ierr = 0
      if (n .eq. 1) go to 1001
!
      do 100 i = 2, n
      e(i-1) = e(i)
  100 continue
!
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
!
      do 240 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
!     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
!     .......... e(n) is always zero, so there is no exit
!                through the bottom of the loop ..........
  110    continue
!
  120    if (m .eq. l) go to 220
  130    if (j .eq. 30) go to 1000
         j = j + 1
!     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = mli_pythag(p,1.0d0)
         if (p . ge. 0.e0) then
            mli_dsign = dabs(r)
         end if

         if (p .lt. 0.e0) then
            mli_dsign = -dabs(r)
         end if

         d(l) = e(l) / (p + mli_dsign)
         d(l1) = e(l) * (p + mli_dsign)
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
!
         do 140 i = l2, n
         d(i) = d(i) - h
  140    continue
!
  145    f = f + h
!     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
!     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = mli_pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
!     .......... form vector ..........
            do 180 k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * h
               z(k,i) = c * z(k,i) - s * h
  180       continue
!
  200    continue
!
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  220    d(l) = d(l) + f
  240 continue
!     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
!
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
!
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
!
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
!
  300 continue
!
      go to 1001
!     .......... set error -- no convergence to an
!                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end

! **********************************************************************
!
!     this subroutine is a translation of the algol procedure tred1,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix
!     to a symmetric tridiagonal matrix using
!     orthogonal similarity transformations.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        a contains the real symmetric input matrix.  only the
!          lower triangle of the matrix need be supplied.
!
!     on output
!
!        a contains information about the orthogonal trans-
!          formations used in the reduction in its strict lower
!          triangle.  the full upper triangle of a is unaltered.
!
!        d contains the diagonal elements of the tridiagonal matrix.
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero.
!
!        e2 contains the squares of the corresponding elements of e.
!          e2 may coincide with e if the squares are not needed.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
! ----------------------------------------------------------------------
!
      subroutine mli_tred1(nm,n,a,d,e,e2)
      integer i,j,k,l,n,ii,nm,jp1
      double precision mli_dsign
      double precision a(nm,n),d(n),e(n),e2(n)
      double precision f,g,h,scale
!
      do 100 i = 1, n
         d(i) = a(n,i)
         a(n,i) = a(i,i)
  100 continue
!     .......... for i=n step -1 until 1 do -- ..........
      do 300 ii = 1, n
         i = n + 1 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 1) go to 130
!     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
           scale = scale + dabs(d(k))
  120    continue
!
         if (scale .ne. 0.0d0) go to 140
!
         do 125 j = 1, l
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = 0.0d0
  125    continue
!
  130    e(i) = 0.0d0
         e2(i) = 0.0d0
         go to 300
!
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
!
         e2(i) = scale * scale * h
         f = d(l)
         if (f . ge. 0.e0) then
            mli_dsign = dsqrt(h)
         end if

         if (f .lt. 0.e0) then
            mli_dsign = -dsqrt(h)
         end if
         g = -mli_dsign
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
         if (l .eq. 1) go to 285
!     .......... form a*u ..........
         do 170 j = 1, l
         e(j) = 0.0d0
  170    continue
!
         do 240 j = 1, l
            f = d(j)
            g = e(j) + a(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
!
            do 200 k = jp1, l
               g = g + a(k,j) * d(k)
               e(k) = e(k) + a(k,j) * f
  200       continue
!
  220       e(j) = g
  240    continue
!     .......... form p ..........
         f = 0.0d0
!
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
!
         h = f / (h + h)
!     .......... form q ..........
         do 250 j = 1, l
         e(j) = e(j) - h * d(j)
  250    continue
!     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
!
            do 260 k = j, l
            a(k,j) = a(k,j) - f * e(k) - g * d(k)
  260       continue
!
  280    continue
!
  285    do 290 j = 1, l
            f = d(j)
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = f * scale
  290    continue
!
  300 continue
!
      return
      end

! **********************************************************************
!
!     this subroutine is a translation of the algol procedure tred2,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix to a
!     symmetric tridiagonal matrix using and accumulating
!     orthogonal similarity transformations.
!
!     on input
!
!        nm must be set to the row dimension of two-dimensional
!          array parameters as declared in the calling program
!          dimension statement.
!
!        n is the order of the matrix.
!
!        a contains the real symmetric input matrix.  only the
!          lower triangle of the matrix need be supplied.
!
!     on output
!
!        d contains the diagonal elements of the tridiagonal matrix.
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero.
!
!        z contains the orthogonal transformation matrix
!          produced in the reduction.
!
!        a and z may coincide.  if distinct, a is unaltered.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
! ----------------------------------------------------------------------
!
      subroutine mli_tred2(nm,n,a,d,e,z)
      integer i,j,k,l,n,ii,nm,jp1
      double precision mli_dsign
      double precision a(nm,n),d(n),e(n),z(nm,n)
      double precision f,g,h,hh,scale

      do 100 i = 1, n
!
         do 80 j = i, n
         z(j,i) = a(j,i)
   80    continue
!
         d(i) = a(n,i)
  100 continue
!
      if (n .eq. 1) go to 510
!     .......... for i=n step -1 until 2 do -- ..........
      do 300 ii = 2, n
         i = n + 2 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 2) go to 130
!     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
         scale = scale + dabs(d(k))
  120    continue
!
         if (scale .ne. 0.0d0) go to 140
  130    e(i) = d(l)
!
         do 135 j = 1, l
            d(j) = z(l,j)
            z(i,j) = 0.0d0
            z(j,i) = 0.0d0
  135    continue
!
         go to 290
!
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
!
         f = d(l)
         if (f . ge. 0.e0) then
            mli_dsign = dsqrt(h)
         end if

         if (f .lt. 0.e0) then
            mli_dsign = -dsqrt(h)
         end if
         g = -mli_dsign
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
!     .......... form a*u ..........
         do 170 j = 1, l
         e(j) = 0.0d0
  170    continue
!
         do 240 j = 1, l
            f = d(j)
            z(j,i) = f
            g = e(j) + z(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
!
            do 200 k = jp1, l
               g = g + z(k,j) * d(k)
               e(k) = e(k) + z(k,j) * f
  200       continue
!
  220       e(j) = g
  240    continue
!     .......... form p ..........
         f = 0.0d0
!
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
!
         hh = f / (h + h)
!     .......... form q ..........
         do 250 j = 1, l
         e(j) = e(j) - hh * d(j)
  250    continue
!     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
!
            do 260 k = j, l
            z(k,j) = z(k,j) - f * e(k) - g * d(k)
  260       continue
!
            d(j) = z(l,j)
            z(i,j) = 0.0d0
  280    continue
!
  290    d(i) = h
  300 continue
!     .......... accumulation of transformation matrices ..........
      do 500 i = 2, n
         l = i - 1
         z(n,l) = z(l,l)
         z(l,l) = 1.0d0
         h = d(i)
         if (h .eq. 0.0d0) go to 380
!
         do 330 k = 1, l
         d(k) = z(k,i) / h
  330    continue
!
         do 360 j = 1, l
            g = 0.0d0
!
            do 340 k = 1, l
            g = g + z(k,i) * z(k,j)
  340       continue
!
            do 370 k = 1, l
               z(k,j) = z(k,j) - g * d(k)
  370       continue
  360    continue
!
  380    do 400 k = 1, l
         z(k,i) = 0.0d0
  400    continue
!
  500 continue
!
  510 do 520 i = 1, n
         d(i) = z(n,i)
         z(n,i) = 0.0d0
  520 continue
!
      z(n,n) = 1.0d0
      e(1) = 0.0d0
      return
      end

! **********************************************************************
!     finds dsqrt(a**2+b**2) without overflow or destructive underflow
! ----------------------------------------------------------------------
!
      double precision function mli_pythag(a,b)
      double precision a,b
!
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 mli_pythag = p
      return
      end

! **********************************************************************

      double precision function mli_dsign(a,b)
      double precision a,b

      if (b .ge. 0.e0) then
         mli_dsign = dabs(a)
         return
      endif

      if (b .lt. 0.e0) then
         mli_dsign =-dabs(a)
         return
      endif
      end


!> Module containing three types of sparse matrices:
!> * Linked list (llsparse)
!> * COOrdinate storage (coosparse)
!> * Compressed Row Storage (crssparse)

!> @todo Implementation of parameterized derived-type declarations to allow single- and double-precision sparse matrices
!> @todo Implementation of ordering for ll and coo
!> @todo Generalization of the solve_crs method (for different solvers)

module modsparse
#if (_DP==0)
 use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real32
#else
 use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real64
#endif
 use iso_c_binding,only:c_ptr,c_null_ptr
#if (_PARDISO==1)
 use modvariablepardiso, only: pardiso_variable
#endif
 !$ use omp_lib
 implicit none
 private
 public::gen_sparse
 public::llsparse,coosparse,crssparse
 public::assignment(=)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!GEN!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
 integer(kind=int32),parameter::typegen=1,typecoo=10,typecrs=20,typell=30

 real(kind=wp),parameter::tol=1.e-10_wp

 !> @brief Generic object containing dimensions, storage format, and output unit
 type,abstract::gen_sparse
  private
  integer(kind=int32)::unlog=output_unit
  integer(kind=int32)::dim1,dim2
  integer(kind=int32),allocatable::perm(:)  !Ap(i,:)=A(perm(i),:)
  character(len=15)::namemat='UNKNOWN'
  logical::lsorted
  logical::lsymmetric
  logical::lupperstorage
  contains
  private
  procedure(destroy_gen),public,deferred::destroy
  procedure(get_gen),public,deferred::get
  procedure(multbyv_gen),deferred::multbyv
  procedure(multbym_gen),deferred::multbym
  procedure(nonzero_gen),public,deferred::nonzero
  procedure(print_gen),public,deferred::print
  procedure(printsquare_gen),public,deferred::printsquare
  procedure(scale_gen),public,deferred::scale

  !> @brief Iterative solver with the conjugate gradient method
  procedure,public::cg=>cg_gen
  !> @brief Returns the dimension of the matrix; e.g., ...=mat%getdim(1)
  procedure,public::getdim=>getdim_gen
  !> @brief Initializes the values
  procedure,public::initialize=>init_gen
  !> @brief Returns true if the matrix is sorted; else returns false
  procedure,public::issorted
  !> @brief Returns true if square matrix; else returns false
  procedure,public::issquare
  !> @brief Multiplication with a vector or matrix
  generic,public::mult=>multbyv,multbym
  !> @brief Prints the sparse matrix to a file
  procedure,public::printtofile=>printtofile_gen
  !> @brief Prints the sparse matrix in a rectangular/square format to the output mat\%unlog
  procedure,public::printsquaretofile=>printsquaretofile_gen
  !> @brief Prints the current status of a sparse matrix to the output mat\%unlog ; e.g., call mat%printstats()
  procedure,public::printstats=>print_dim_gen
  !> @brief Sets the output unit to value; e.g., call mat%setouputunit(unlog)
  procedure,public::setoutputunit
  !> @brief Sets the permutation vector; e.g., call mat%setpermutation(array)
  procedure,public::setpermutation
  procedure::setsorted
  !> @brief Sets the assumption that the matrix is symmetric, if the matrix is square (there is no other check)
  procedure,public::setsymmetric
  procedure::destroy_gen_gen
  procedure::getmem_gen
 end type

 abstract interface
  subroutine scale_gen(sparse, val)
   import::gen_sparse,wp
   class(gen_sparse),intent(inout)::sparse
   real(kind=wp),intent(in)::val
  end subroutine
  subroutine destroy_gen(sparse)
   import::gen_sparse
   class(gen_sparse),intent(inout)::sparse
  end subroutine
  function get_gen(sparse,row,col) result(val)
   import::int32,wp,gen_sparse
   class(gen_sparse),intent(in)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp)::val
  end function
  subroutine multbyv_gen(sparse,alpha,trans,x,val,y)
   import::wp,gen_sparse
   class(gen_sparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:)
   real(kind=wp),intent(out)::y(:)
   character(len=1),intent(in)::trans
  end subroutine
  subroutine multbym_gen(sparse,alpha,trans,x,val,y)
   import::wp,gen_sparse
   class(gen_sparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:,:)
   real(kind=wp),intent(out)::y(:,:)
   character(len=1),intent(in)::trans
  end subroutine
  function nonzero_gen(sparse) result(nel)
   import::int64,gen_sparse
   class(gen_sparse),intent(in)::sparse
   integer(kind=int64)::nel
  end function
  subroutine print_gen(sparse,lint,output)
   import::int32,gen_sparse
   class(gen_sparse),intent(in)::sparse
   integer(kind=int32),intent(in),optional::output
   logical,intent(in),optional::lint
  end subroutine
  subroutine printsquare_gen(sparse,output)
   import::int32,gen_sparse
   class(gen_sparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::output
   end subroutine
 end interface

 interface
  !DESTROY
  !> @brief Subroutine to reset/destroy a generic object
  module subroutine destroy_gen_gen(sparse)
   class(gen_sparse),intent(inout)::sparse
  end subroutine
  !**CONJUGATE GRADIENT
  module subroutine cg_gen(sparse,x,y,maxiter,tol)
   !sparse*x=y
   class(gen_sparse),intent(in)::sparse
   integer(kind=int32),intent(inout),optional::maxiter
   real(kind=wp),intent(inout)::x(:)
   real(kind=wp),intent(in)::y(:)
   real(kind=wp),intent(inout),optional::tol
  end subroutine
  !**GET ELEMENTS
  pure module function getdim_gen(sparse,dim1) result(dimget)
   class(gen_sparse),intent(in)::sparse
   integer(kind=int32),intent(in)::dim1
   integer(kind=int32)::dimget
  end function
  !GET MEMORY
  module function getmem_gen(sparse) result(getmem)
   class(gen_sparse),intent(in)::sparse
   integer(kind=int64)::getmem
  end function
  !INITIATE GEN SPARSE
  module subroutine init_gen(sparse,namemat,dim1,dim2)
   class(gen_sparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::dim1,dim2
   character(len=*),intent(in)::namemat
  end subroutine
  !**PRINT
  module subroutine print_dim_gen(sparse)
   class(gen_sparse),intent(in)::sparse
  end subroutine
  module subroutine printtofile_gen(sparse,namefile,lint)
   class(gen_sparse),intent(in)::sparse
   character(len=*),intent(in)::namefile
   logical,intent(in),optional::lint
  end subroutine
  module subroutine printsquaretofile_gen(sparse,namefile)
   class(gen_sparse),intent(inout)::sparse
   character(len=*),intent(in)::namefile
  end subroutine
  !**SET OUTPUT UNIT
  module subroutine setoutputunit(sparse,unlog)
   class(gen_sparse),intent(inout)::sparse
   integer(kind=int32)::unlog
  end subroutine
  !** SET PERMUTATION VECTOR
  module subroutine setpermutation(sparse,array)
   class(gen_sparse),intent(inout)::sparse
   integer(kind=int32)::array(:)
  end subroutine
  ! SET THE STATUS SORTED
  module subroutine setsorted(sparse,ll)
   class(gen_sparse),intent(inout)::sparse
   logical,intent(in)::ll
  end subroutine
  ! SET THE STATUS SYMMETRIC
  module subroutine setsymmetric(sparse,ll)
   class(gen_sparse),intent(inout)::sparse
   logical,intent(in),optional::ll
  end subroutine
  !**OTHER
  module function issorted(sparse) result(ll)
   class(gen_sparse),intent(in)::sparse
   logical::ll
  end function
  module function issquare(sparse) result(ll)
   class(gen_sparse),intent(in)::sparse
   logical::ll
  end function
 end interface

 interface
  !CHECKS
  module function validvalue_gen(sparse,row,col) result(lvalid)
   class(gen_sparse),intent(in)::sparse
   integer(kind=int32),intent(in)::row,col
   logical::lvalid
  end function
  module function validnonzero_gen(sparse,val) result(lvalid)
   class(gen_sparse),intent(in)::sparse
   real(kind=wp),intent(in)::val
   logical::lvalid
  end function
  module function uppervalue_gen(row,col) result(lvalid)
   integer(kind=int32),intent(in)::row,col
   logical::lvalid
  end function
 end interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!COO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa

 !> @brief Object for COOrdinate storage
 type,extends(gen_sparse)::coosparse
  private
  integer(kind=int32),allocatable::ij(:,:)
  integer(kind=int64)::nel
  integer(kind=int64)::filled
  real(kind=wp),allocatable::a(:)
  contains
  private
  !> @brief Adds the value val to mat(row,col); e.g., call mat\%add(row,col,val)
  procedure,public::add=>add_coo
  !> @brief Deallocates the sparse matrix and sets to default values
  procedure,public::destroy=>destroy_coo
  procedure::diag_vect_coo
  procedure::diag_mat_coo
  !> @brief Gets the (upper) diagonal elements of a matrix; e.g., array=mat%diag()
  !! OR mat=mat%diag(10) (to extract the diagonal + 10 off-diagonals)
  generic,public::diag=>diag_vect_coo,diag_mat_coo
  !> @brief Returns the value of mat(row,col); e.g., ...=mat\%get(row,col)
  procedure,public::get=>get_coo
  !> @brief Gets memory used
  procedure,public::getmem=>getmem_coo
  !> @brief Initializes coosparse
  procedure,public::init=>constructor_sub_coo
  !> @brief Multiplication with a vector (not fully implemented)
  procedure::multbyv=>multgenv_coo
  !> @brief Multiplication with a matrix (not fully implemented)
  procedure::multbym=>multgenm_coo
  !> @brief Returns the number of non-zero elements
  procedure,public::nonzero=>totalnumberofelements_coo
  !> @brief Prints the sparse matrix to the output mat\%unlog
  procedure,public::print=>print_coo
  !> @brief Prints the sparse matrix in a rectangular/square format to the default output
  procedure,public::printsquare=>printsquare_coo
  !> @brief Saves the matrix (internal format) to stream file
  procedure,public::save=>save_coo
  !> @brief Scales all entries of mat by real scalar val; e.g., call mat\%scale(val)
  procedure,public::scale=>scale_coo
  !> @brief Sets an entry to a certain value (even if equal to 0); e.g., call mat\%set(row,col,val)
  procedure,public::set=>set_coo
  !> @brief Gets a submatrix from a sparse matrix
  procedure,public::submatrix=>submatrix_coo
  final::deallocate_scal_coo,deallocate_rank1_coo
 end type

 interface
  !**CONSTRUCTOR
  module function constructor_coo(m,n,nel,lupper,unlog) result(sparse)
   type(coosparse)::sparse
   integer(kind=int32),intent(in)::m
   integer(kind=int32),intent(in),optional::n,unlog
   integer(kind=int64),intent(in),optional::nel
   logical,intent(in),optional::lupper
  end function
  module subroutine constructor_sub_coo(sparse,m,n,nel,lupper,unlog)
   class(coosparse),intent(out)::sparse
   integer(kind=int32),intent(in)::m
   integer(kind=int32),intent(in),optional::n,unlog
   integer(kind=int64),intent(in),optional::nel
   logical,intent(in),optional::lupper
  end subroutine
  !**DESTROY
  module subroutine destroy_coo(sparse)
   class(coosparse),intent(inout)::sparse
  end subroutine
  !**DIAGONAL ELEMENTS
  module function diag_vect_coo(sparse) result(array)
   class(coosparse),intent(inout)::sparse
   real(kind=wp),allocatable::array(:)
  end function
  !**ADD ELEMENTS
  module recursive subroutine add_coo(sparse,row,col,val)
   class(coosparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp),intent(in)::val
  end subroutine
  !**GET ELEMENTS
  module function get_coo(sparse,row,col) result(val)
   class(coosparse),intent(in)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp)::val
  end function
  !** GET MEMORY
  module function getmem_coo(sparse) result(getmem)
   class(coosparse),intent(in)::sparse
   integer(kind=int64)::getmem
  end function
  !**EXTERNAL
  !**LOAD
  module function load_coo(namefile,unlog) result(sparse)
   type(coosparse)::sparse
   character(len=*),intent(in)::namefile
   integer(kind=int32),intent(in),optional::unlog
  end function
  !**MULTIPLICATIONS
  module subroutine multgenv_coo(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(coosparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:)
   real(kind=wp),intent(out)::y(:)
   character(len=1),intent(in)::trans
  end subroutine
  module subroutine multgenm_coo(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(coosparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:,:)
   real(kind=wp),intent(out)::y(:,:)
   character(len=1),intent(in)::trans
  end subroutine
  !**NUMBER OF ELEMENTS
  module function totalnumberofelements_coo(sparse) result(nel)
   class(coosparse),intent(in)::sparse
   integer(kind=int64)::nel
  end function
  !**PRINT
  module subroutine print_coo(sparse,lint,output)
   class(coosparse),intent(in)::sparse
   integer(kind=int32),intent(in),optional::output
   logical,intent(in),optional::lint
  end subroutine
  module subroutine printsquare_coo(sparse,output)
   class(coosparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::output
  end subroutine
  !**SAVE
  module subroutine save_coo(sparse,namefile)
   class(coosparse),intent(in)::sparse
   character(len=*),intent(in)::namefile
  end subroutine
  !**SCALE ALL ENTRIES
  module subroutine scale_coo(sparse,val)
   class(coosparse),intent(inout)::sparse
   real(kind=wp),intent(in)::val
  end subroutine
  !**SET ELEMENTS
  module recursive subroutine set_coo(sparse,row,col,val)
   !from add_coo
   class(coosparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp),intent(in)::val
  end subroutine
  !**SOLVE
  !**SORT ARRAY
  !**SUBMATRIX
  module function submatrix_coo(sparse,startdim1,enddim1,startdim2,enddim2,lupper,unlog) result(subsparse)
   !Not programmed efficiently, but it should do the job
   class(coosparse),intent(in)::sparse
   type(coosparse)::subsparse
   integer(kind=int32),intent(in)::startdim1,enddim1,startdim2,enddim2
   integer(kind=int32),intent(in),optional::unlog
   logical,intent(in),optional::lupper
  end function
 end interface

! !> @brief Load a COO matrix from file
! interface cooload
!  module procedure load_coo
! end interface

 !> @brief Constructor; e.g., mat=coosparse(dim1,[dim2],[#elements],[upper_storage],[output_unit])
 !! OR mat=coosparse('file',[output_unit])
 interface coosparse
  module procedure constructor_coo,load_coo
 end interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!CRS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
 !> @brief Object for Compressed Row Storage
 type,extends(gen_sparse)::crssparse
  private
  integer(kind=int32),allocatable::ia(:)
  integer(kind=int32),allocatable::ja(:)
  real(kind=wp),allocatable::a(:)
#if (_PARDISO==1)
  logical::lpardisofirst
  type(pardiso_variable)::pardisovar
#endif
  contains
  private
  !> @brief Adds the value val to mat(row,col); e.g., call mat\%add(row,col,val)
  procedure,public::add=>add_crs
#if (_SPAINV==1)
  !> @brief Computes and replaces the sparse matrix by the (complete) Cholesky factor
  procedure,public::chol=>getchol_crs
#endif
  !> @brief Deallocates the sparse matrix and sets to default values
  procedure,public::destroy=>destroy_crs
  procedure::diag_vect_crs
  procedure::diag_mat_crs
  !> @brief Gets the (upper) diagonal elements of a matrix; e.g., array=mat%diag()
  !! OR mat=mat%diag(10) (to extract the diagonal + 10 off-diagonals)
  generic,public::diag=>diag_vect_crs,diag_mat_crs
  !> @brief Returns the value of mat(row,col); e.g., ...=mat\%get(row,col)
  procedure,public::get=>get_crs
#if (_SPAINV==1)
  !> @brief Computes and replaces the sparse matrix by the (complete) LDLt (L is stored in the upper triangle and D in the diagonal)
  procedure,public::getldlt=>getldlt_crs
#endif
  !> @brief Gets memory used
  procedure,public::getmem=>getmem_crs
  !> @brief Initializes the vectors ia,ja,and a from external vectors
  procedure,public::external=>external_crs
#if (_SPAINV==1)
  !> @brief Computes and replaces the sparse matrix by an incomplete Cholesky factor
  procedure,public::ichol=>getichol_crs
#endif
  !> @brief Iniates crssparse
  procedure,public::init=>constructor_sub_crs
  !> @brief Solver with a triangular factor (e.g., a Cholesky factor or an incomplete Cholesky factor)
  procedure,public::isolve=>isolve_crs
  !> @brief Solver using LDLt decomposition
  procedure,public::solveldlt=>solveldlt_crs
  !> @brief Multiplication with a vector
  procedure::multbyv=>multgenv_csr
  !> @brief Multiplication with a matrix
  procedure::multbym=>multgenm_csr
  !> @brief Returns the number of non-zero elements
  procedure,public::nonzero=>totalnumberofelements_crs
#if (_METIS==1)
  !> @brief Returns the ordering array obtained from METIS
  procedure,public::getordering=>getordering_crs
#endif
  !> @brief Releases Pardiso memory if possible
#if (_PARDISO==1)
  procedure,public::resetpardiso=>reset_pardiso_memory_crs
#endif
  !> @brief Prints the sparse matrix to the output sparse\%unlog
  procedure,public::print=>print_crs
  !> @brief Prints the sparse matrix in a rectangular/square format to the default output
  procedure,public::printsquare=>printsquare_crs
  !> @brief Saves the matrix (internal format) to stream file
  procedure,public::save=>save_crs
  !> @brief Scales all entries of mat by real scalar val; e.g., call mat\%scale(val)
  procedure,public::scale=>scale_crs
  !> @brief Sets an entry to a certain value (even if equal to 0); condition: the entry must exist; e.g., call mat\%set(row,col,val)
  procedure,public::set=>set_crs
  !> @brief MKL PARDISO solver
  procedure,private::solve_crs_vector
  procedure,private::solve_crs_array
  generic,public::solve=>solve_crs_vector,solve_crs_array
  !> @brief Sorts the elements in a ascending order within a row
  procedure,public::sort=>sort_crs
#if (_SPAINV==1)
  !> @brief Computes and replaces by the sparse inverse
  procedure,public::spainv=>getspainv_crs
#endif
  !> @brief Gets a submatrix from a sparse matrix
  procedure,public::submatrix=>submatrix_crs
  final::deallocate_scal_crs,deallocate_rank1_crs
 end type

 interface
  !**CONSTRUCTOR
  module function constructor_crs(m,nel,n,lupper,unlog) result(sparse)
   type(crssparse)::sparse
   integer(kind=int32),intent(in)::m
   integer(kind=int32),intent(in)::nel
   integer(kind=int32),intent(in),optional::n,unlog
   logical,intent(in),optional::lupper
  end function
  module subroutine constructor_sub_crs(sparse,m,nel,n,lupper,unlog)
   class(crssparse),intent(out)::sparse
   integer(kind=int32),intent(in)::m
   integer(kind=int32),intent(in)::nel
   integer(kind=int32),intent(in),optional::n,unlog
   logical,intent(in),optional::lupper
  end subroutine
  !**DESTROY
  module subroutine destroy_crs(sparse)
   class(crssparse),intent(inout)::sparse
  end subroutine
  !**DIAGONAL ELEMENTS
  module function diag_vect_crs(sparse) result(array)
   class(crssparse),intent(inout)::sparse
   real(kind=wp),allocatable::array(:)
  end function
  !**ADD ELEMENTS
  module subroutine add_crs(sparse,row,col,val,error)
   !add a value only to an existing one
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::row,col
   integer(kind=int32),intent(out),optional::error
   real(kind=wp),intent(in)::val
  end subroutine
  !**GET ELEMENTS
  module function get_crs(sparse,row,col) result(val)
   class(crssparse),intent(in)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp)::val
  end function
  !** GET MEMORY
  module function getmem_crs(sparse) result(getmem)
   class(crssparse),intent(in)::sparse
   integer(kind=int64)::getmem
  end function
  !**EXTERNAL
  module subroutine external_crs(sparse,ia,ja,a)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::ia(:),ja(:)
   real(kind=wp),intent(in)::a(:)
  end subroutine
  !**MULTIPLICATIONS
  module subroutine multgenv_csr(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(crssparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:)
   real(kind=wp),intent(out)::y(:)
   character(len=1),intent(in)::trans
  end subroutine
  module subroutine multgenm_csr(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(crssparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:,:)
   real(kind=wp),intent(out)::y(:,:)
   character(len=1),intent(in)::trans
  end subroutine
  !**NUMBER OF ELEMENTS
  module function totalnumberofelements_crs(sparse) result(nel)
   class(crssparse),intent(in)::sparse
   integer(kind=int64)::nel
  end function
#if (_SPAINV==1)
  !**GET (COMPLETE) CHOLESKY FACTOR
  module subroutine getchol_crs(sparse,minsizenode)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::minsizenode
  end subroutine
  !**GET LDLt DECOMPOSITION
  module subroutine getldlt_crs(sparse,minsizenode)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::minsizenode
  end subroutine
#endif
#if (_METIS==1)
  !**GET ORDER
  module function getordering_crs(sparse&
                            ,ctype,iptype,rtype,compress,ccorder&
                            ,pfactor,nseps,bglvl&
                            ) result(perm)
   class(crssparse),intent(in)::sparse
   integer(kind=int32),intent(in),optional::ctype,iptype,rtype,compress,ccorder,pfactor,nseps,bglvl
   integer(kind=int32),allocatable::perm(:)
  end function
#endif
#if (_SPAINV==1)
  !**GET INCOMPLETE CHOLESKY FACTOR
  module subroutine getichol_crs(sparse,minsizenode)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::minsizenode
  end subroutine
  !**GET SPARSE INVERSE
  module subroutine getspainv_crs(sparse,minsizenode)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::minsizenode
  end subroutine
#endif
#if (_PARDISO==1)
  !**RESET PARDISO MEMORY
  module subroutine reset_pardiso_memory_crs(sparse)
   !sparse*x=y
   class(crssparse),intent(inout)::sparse
  end subroutine
#endif
  !**PRINT
  module subroutine print_crs(sparse,lint,output)
   class(crssparse),intent(in)::sparse
   integer(kind=int32),intent(in),optional::output
   logical,intent(in),optional::lint
  end subroutine
  module subroutine printsquare_crs(sparse,output)
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::output
  end subroutine
  !**SAVE
  module subroutine save_crs(sparse,namefile)
   class(crssparse),intent(in)::sparse
   character(len=*),intent(in)::namefile
  end subroutine
  !**SCALE ALL ENTRIES
  module subroutine scale_crs(sparse,val)
   class(crssparse),intent(inout)::sparse
   real(kind=wp),intent(in)::val
  end subroutine
  !**SET ELEMENTS
  module subroutine set_crs(sparse,row,col,val,error)
   !add a value only to an existing one
   class(crssparse),intent(inout)::sparse
   integer(kind=int32),intent(in)::row,col
   integer(kind=int32),intent(out),optional::error
   real(kind=wp),intent(in)::val
  end subroutine
  !**SOLVE
  module subroutine solve_crs_vector(sparse,x,y)
   !sparse*x=y
   class(crssparse),intent(inout)::sparse
   real(kind=wp),intent(out),contiguous::x(:)
   real(kind=wp),intent(inout),contiguous::y(:)
  end subroutine
  module subroutine solve_crs_array(sparse,x,y)
   !sparse*x=y
   class(crssparse),intent(inout)::sparse
   real(kind=wp),intent(out),contiguous::x(:,:)
   real(kind=wp),intent(inout),contiguous::y(:,:)
  end subroutine
  !**SOLVE WITH A TRIANGULAR FACTOR
  module subroutine isolve_crs(sparse,x,y)
   !sparse*x=y
   class(crssparse),intent(in)::sparse
   real(kind=wp),intent(out)::x(:)
   real(kind=wp),intent(in)::y(:)
  end subroutine
  !**SOLVE WITH LDLt DECOMPOSITION
  module subroutine solveldlt_crs(sparse,x,y)
   !sparse*x=y
   class(crssparse),intent(in)::sparse
   real(kind=wp),intent(out)::x(:)
   real(kind=wp),intent(in)::y(:)
  end subroutine
  !**SORT ARRAY
  module subroutine sort_crs(sparse)
   ! sort vectors ja and a by increasing order
   class(crssparse),intent(inout)::sparse
  end subroutine
 end interface

! !> @brief Load a CRS matrix from file
! interface crsload
!  module procedure load_crs
! end interface

 !> @brief Constructor; e.g., mat=crsparse(dim1,#elements,[dim2],[upper_storage],[output_unit])
 !! OR mat=crssparse('file',[output_unit])
 interface crssparse
  module procedure constructor_crs,load_crs
 end interface

!!!!!!!!!!!!!!!!!!!!!!!LINKED LIST!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
 type::ptrnode
  type(node),pointer::p=>null()
  contains
  procedure,public::size=>totalnumberofelements_ptrnode
 end type

 !> @brief Object for Linked List
 type,extends(gen_sparse)::llsparse
  private
  type(ptrnode),allocatable::heads(:)
  contains
  private
  !> @brief Adds the value val to mat(row,col); e.g., call mat\%add(row,col,val)
  procedure,public::add=>addinorder_ll
  procedure,public::addfast =>addtohead_ll
  procedure,public::addtohead =>addtohead_ll
  procedure,public::addtotail =>addtotail_ll
  !> @brief Returns the value of mat(row,col); e.g., ...=mat\%get(row,col)
  procedure,public::get=>get_ll
  !> @brief Initializes llsparse
  procedure,public::init=>constructor_sub_ll
  !> @brief Multiplication with a vector
  procedure::multbyv=>multgenv_ll
  !> @brief Multiplication with a matrix
  procedure::multbym=>multgenm_ll
  !> @brief Returns the number of non-zero elements
  procedure,public::nonzero=>totalnumberofelements_ll
  !> @brief Prints the sparse matrix to the output sparse\%unlog
  procedure,public::print=>print_ll
  !> @brief Prints the sparse matrix in a rectangular/square format to the default output
  procedure,public::printsquare=>printsquare_ll
  !> @brief Scales all entries of mat by real scalar val; e.g., call mat\%scale(val)
  procedure,public::scale=>scale_ll
  !> @brief Deallocates the sparse matrix and sets to default values
  procedure,public::destroy=>destroy_ll
  final::deallocate_scal_ll,deallocate_rank1_ll
 end type

 type::node
  integer(kind=int32)::col
  real(kind=wp)::val
  type(ptrnode)::next
  contains
  private
  procedure::equal_node
  generic,public::assignment(=)=>equal_node
 end type

 interface
  !**CONSTRUCTOR
  module subroutine constructor_sub_ll(sparse,m,n,lupper,unlog)
   class(llsparse),intent(out)::sparse
   integer(kind=int32),intent(in)::m
   integer(kind=int32),intent(in),optional::n,unlog
   logical,intent(in),optional::lupper
  end subroutine
  !**DESTROY
  module subroutine destroy_scal_ptrnode(pnode)
   type(ptrnode)::pnode
  end subroutine
  module subroutine destroy_ll(sparse)
   class(llsparse),intent(inout)::sparse
  end subroutine
  !**DIAGONAL ELEMENTS
  !EQUALITIES
  module subroutine equal_node(nodeout,nodein)
   class(node),intent(out)::nodeout
   class(node),intent(in)::nodein
  end subroutine
  !**ADD ELEMENTS
  module subroutine addtohead_ptrnode(pnode,col,val)
   type(ptrnode),intent(inout),pointer::pnode
   integer(kind=int32),intent(in)::col
   real(kind=wp),intent(in)::val
  end subroutine
  module subroutine addtohead_ll(sparse,row,col,val)
   class(llsparse),intent(inout),target::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp),intent(in)::val
  end subroutine
  module subroutine addinorder_ll(sparse,row,col,val)
   class(llsparse),intent(inout),target::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp),intent(in)::val
  end subroutine
  module subroutine addtotail_ll(sparse,row,col,val)
   class(llsparse),intent(inout),target::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp),intent(in)::val
  end subroutine
  !**GET ELEMENTS
  module function get_ll(sparse,row,col) result(val)
   class(llsparse),intent(in)::sparse
   integer(kind=int32),intent(in)::row,col
   real(kind=wp)::val
  end function
  !**EXTERNAL
  !**LOAD
  !**MULTIPLICATIONS
  module subroutine multgenv_ll(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(llsparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:)
   real(kind=wp),intent(out)::y(:)
   character(len=1),intent(in)::trans
  end subroutine
  module subroutine multgenm_ll(sparse,alpha,trans,x,val,y)
   !Computes y=val*y+alpha*sparse(tranposition)*x
   class(llsparse),intent(in)::sparse
   real(kind=wp),intent(in)::val,alpha
   real(kind=wp),intent(in)::x(:,:)
   real(kind=wp),intent(out)::y(:,:)
   character(len=1),intent(in)::trans
  end subroutine
  !**NUMBER OF ELEMENTS
  module function totalnumberofelements_ptrnode(pnode) result(nel)
   class(ptrnode),intent(in),target::pnode
   integer(kind=int64)::nel
  end function
  module function totalnumberofelements_ll(sparse) result(nel)
   class(llsparse),intent(in)::sparse
   integer(kind=int64)::nel
  end function
  !**SAVE
  !**SCALE ALL ENTRIES
  module subroutine scale_ll(sparse,val)
   class(llsparse),intent(inout)::sparse
   real(kind=wp),intent(in)::val
  end subroutine
  !**SET ELEMENTS
  !**SOLVE
  !**SORT ARRAY
  !**SUBMATRIX
  !**PRINT
  module subroutine print_ll(sparse,lint,output)
   class(llsparse),intent(in)::sparse
   integer(kind=int32),intent(in),optional::output
   logical,intent(in),optional::lint
  end subroutine
  module subroutine printsquare_ll(sparse,output)
   class(llsparse),intent(inout)::sparse
   integer(kind=int32),intent(in),optional::output
  end subroutine
 end interface

 !> @brief Constructor; e.g., mat=llsparse(dim1,[dim2],[upper_storage],[output_unit])
 interface llsparse
  module procedure constructor_ll
 end interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!METIS GRAPH DATA STRUCTURE!!!!!!!!!!!!!!!!!!!!!!!!!aaa
 type::metisgraph
  private
  integer(kind=int32)::unlog
  integer(kind=int32)::nvertices,medges
  integer(kind=int32),allocatable::xadj(:),adjncy(:)
  type(c_ptr)::vwgt
  type(c_ptr)::adjwgt
  contains
  private
  procedure,public::init=>constructor_sub_metisgraph
  procedure,public::destroy=>destroy_metisgraph
  procedure,public::getmem=>getmem_metisgraph
  final::deallocate_scal_metisgraph,deallocate_rank1_metisgraph
 end type

 interface
  !**CONSTRUCTOR
  module subroutine constructor_sub_metisgraph(metis,n,m,unlog)
   class(metisgraph),intent(out)::metis
   integer(kind=int32),intent(in)::n,m
   integer(kind=int32),intent(in),optional::unlog
  end subroutine
  !** GET MEMORY
  module function getmem_metisgraph(metis) result(getmem)
   class(metisgraph),intent(in)::metis
   integer(kind=int64)::getmem
  end function
 end interface

 interface metisgraph
  module procedure constructor_metisgraph
 end interface

!!!!!!!!!!!!!GENERAL INTERFACES!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
 !> @brief Converts sparse matrices from one format to another one; e.g., crsmat=coomat
 interface assignment(=)
  module procedure convertfromlltocoo,convertfromlltocrs&
                  ,convertfromcootocrs,convertfromcootoll&
                  ,convertfromcrstometisgraph&
                  ,convertfromcrstocoo,convertfromcrstoll
 end interface

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!COO!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
!**DIAGONAL ELEMENTS
function diag_mat_coo(sparse,noff) result(diagsparse)
 class(coosparse),intent(inout)::sparse
 integer(kind=int32),intent(in)::noff
 type(coosparse)::diagsparse

 integer(kind=int32)::ndiag,i,j

 ndiag=min(sparse%dim1,sparse%dim2)

 diagsparse=coosparse(ndiag,ndiag,int(ndiag,int64),lupper=.true.)

 do i=1,ndiag
  call diagsparse%add(i,i,sparse%get(i,i))
  do j=i+1,i+noff
   call diagsparse%add(i,j,sparse%get(i,j))
  enddo
 enddo

end function

!FINAL
subroutine deallocate_scal_coo(sparse)
 type(coosparse),intent(inout)::sparse

 call sparse%destroy()

end subroutine

subroutine deallocate_rank1_coo(sparse)
 type(coosparse),intent(inout)::sparse(:)

 integer(kind=int32)::i

 do i=1,size(sparse)
  call sparse(i)%destroy()
 enddo

end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!CRS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
!**DIAGONAL ELEMENTS
function diag_mat_crs(sparse,noff) result(diagsparse)
 class(crssparse),intent(inout)::sparse
 integer(kind=int32),intent(in)::noff
 type(crssparse)::diagsparse

 integer(kind=int32)::ndiag,i,j,k,startoff,endoff,nel
 integer(kind=int32),allocatable::rowpos(:)

 ndiag=min(sparse%dim1,sparse%dim2)

 allocate(rowpos(ndiag))
 rowpos=0

 !determine the number of elements per row
 do i=1,ndiag
  startoff=i+1
  endoff=i+noff
  do j=sparse%ia(i),sparse%ia(i+1)-1
   if(sparse%ja(j).ge.startoff.and.sparse%ja(j).le.endoff)then
    rowpos(i)=rowpos(i)+1
   endif
  enddo
 enddo

 nel=ndiag+sum(rowpos)

 diagsparse=crssparse(ndiag,nel,ndiag,lupper=.true.)

 !determine the number of non-zero off-diagonal elements per row
 diagsparse%ia(2:diagsparse%dim1+1)=rowpos

 !accumulate the number of elements and add diagonal elements
 diagsparse%ia(1)=1
 do i=1,ndiag
  diagsparse%ia(i+1)=diagsparse%ia(i+1)+1+diagsparse%ia(i)
  diagsparse%ja(diagsparse%ia(i))=i   !set diagonal element for the case it would not be present
 enddo

 !add the non-zero elements to crs (diagsparse)
 rowpos=diagsparse%ia(1:diagsparse%dim1)
 do i=1,ndiag
  startoff=i+1
  endoff=i+noff
  do j=sparse%ia(i),sparse%ia(i+1)-1
   k=sparse%ja(j)
   if(i.eq.k)then
    diagsparse%a(diagsparse%ia(i))=sparse%a(j)
   elseif(k.ge.startoff.and.k.le.endoff)then
    rowpos(i)=rowpos(i)+1
    diagsparse%ja(rowpos(i))=k
    diagsparse%a(rowpos(i))=sparse%a(j)
   endif
  enddo
 enddo

 deallocate(rowpos)

end function

!**LOAD
function load_crs(namefile,unlog)  result(sparse)
 type(crssparse)::sparse
 integer(kind=int32),intent(in),optional::unlog
 character(len=*),intent(in)::namefile

 integer(kind=int32)::un,dim1,dim2
 integer(kind=int64)::nonzero
 logical::lupperstorage

 open(newunit=un,file=namefile,action='read',status='old',access='stream')!,buffered='yes')
 read(un)dim1
 if(dim1.ne.typecrs)then
  write(*,'(a)')' ERROR: the proposed file is not a CRS file'
  stop
 endif
 read(un)dim1            !int32
 read(un)dim2            !int32
 read(un)nonzero         !int64
 read(un)lupperstorage   !logical

 if(present(unlog))then
  sparse=crssparse(dim1,int(nonzero,int32),dim2,lupperstorage,unlog)
 else
  sparse=crssparse(dim1,int(nonzero,int32),dim2,lupperstorage)
 endif

 read(un)sparse%ia              !int32
 read(un)sparse%ja              !int32
 read(un)sparse%a               !wp

 close(un)

end function

!**SUBMATRIX
function submatrix_crs(sparse,startdim1,enddim1,startdim2,enddim2,lupper,unlog) result(subsparse)
 !Not programmed efficiently, but it should do the job
 class(crssparse),intent(in)::sparse
 type(crssparse)::subsparse
 integer(kind=int32),intent(in)::startdim1,enddim1,startdim2,enddim2
 integer(kind=int32),intent(in),optional::unlog
 logical,intent(in),optional::lupper

 integer(kind=int32)::i,j,k,nel,un
 logical::lincludediag,lupperstorage
 type(coosparse)::subcoo

 if(.not.validvalue_gen(sparse,startdim1,startdim2))return
 if(.not.validvalue_gen(sparse,enddim1,enddim2))return

 !check if the submatrix include diagonal elements of sparse
 ! if yes -> lupperstorage
 ! if no  -> .not.lupperstorage
 lincludediag=.false.
 firstdim: do i=startdim1,enddim1
  do j=startdim2,enddim2
   if(j.gt.i)exit
   if(i.eq.j)then
    lincludediag=.true.
    exit firstdim
   endif
  enddo
 enddo firstdim

 lupperstorage=sparse%lupperstorage
 if(present(lupper))then
  lupperstorage=lupper
 else
  if(sparse%lupperstorage)then
   lupperstorage=.false.
   if(lincludediag)lupperstorage=.true.
  endif
 endif

 !determine the number of elements
 !possibilities
 nel=0
 if(sparse%lupperstorage.eqv.lupperstorage.or.(sparse%lupperstorage.and..not.lincludediag))then
  ! upper -> upper  ||  full -> full
  do i=startdim1,enddim1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if(k.ge.startdim2.and.k.le.enddim2)then
     nel=nel+1
    endif
   enddo
  enddo
 elseif(sparse%lupperstorage.and..not.lupperstorage)then
  ! upper -> full
  do i=startdim1,enddim1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if(k.ge.startdim2.and.k.le.enddim2)then
     nel=nel+1
    endif
   enddo
  enddo
!  do i=startdim2,enddim2
!   do j=sparse%ia(i),sparse%ia(i+1)-1
!    k=sparse%ja(j)
!    if(i.ne.k.and.k.ge.startdim1.and.k.le.enddim1)then
!     nel=nel+1
!    endif
!   enddo
!  enddo
 elseif(.not.sparse%lupperstorage.and.lupperstorage)then
  ! full -> upper
  do i=startdim1,enddim1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if((k-startdim2+1.ge.i-startdim1+1).and.k.ge.startdim2.and.k.le.enddim2)then
     nel=nel+1
    endif
   enddo
  enddo
 endif

 !add the elements
 if((sparse%lupperstorage.eqv.lupperstorage).or.(sparse%lupperstorage.and..not.lincludediag))then
  ! upper -> upper  ||  full -> full
  if(present(unlog))then
   subsparse=crssparse(enddim1-startdim1+1,nel,enddim2-startdim2+1,lupperstorage,unlog)
  else
   subsparse=crssparse(enddim1-startdim1+1,nel,enddim2-startdim2+1,lupperstorage)
  endif
  subsparse%ia=0
  nel=1
  un=0
  do i=startdim1,enddim1
   un=un+subsparse%ia(nel)
   nel=nel+1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if(k.ge.startdim2.and.k.le.enddim2)then
     subsparse%ia(nel)=subsparse%ia(nel)+1
     subsparse%ja(un+subsparse%ia(nel))=k-startdim2+1
     subsparse%a(un+subsparse%ia(nel))=sparse%a(j)
    endif
   enddo
  enddo
  subsparse%ia(1)=1
  do i=2,subsparse%dim1+1
   subsparse%ia(i)=subsparse%ia(i)+subsparse%ia(i-1)
  enddo
 elseif(sparse%lupperstorage.and..not.lupperstorage)then
  ! upper -> full
  if(present(unlog))then
   subcoo=coosparse(enddim1-startdim1+1,enddim2-startdim2+1,int(nel,int64),lupperstorage,unlog)
  else
   subcoo=coosparse(enddim1-startdim1+1,enddim2-startdim2+1,int(nel,int64),lupperstorage)
  endif
  do i=1,sparse%dim1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if(k.ge.startdim2.and.k.le.enddim2)then
     call subcoo%add(i-startdim1+1,k-startdim2+1,sparse%a(j))
    endif
!    if(i.ne.k)then
!     if((k.ge.startdim1.and.k.le.enddim1).and.(i.ge.startdim2.and.i.le.enddim2))then
!      call subcoo%add(k-startdim1+1,i-startdim2+1,sparse%a(j))
!     endif
!    endif
   enddo
  enddo
  subsparse=subcoo
  call subcoo%destroy()
 elseif(.not.sparse%lupperstorage.and.lupperstorage)then
  ! full -> upper
  if(present(unlog))then
   subsparse=crssparse(enddim1-startdim1+1,nel,enddim2-startdim2+1,lupperstorage,unlog)
  else
   subsparse=crssparse(enddim1-startdim1+1,nel,enddim2-startdim2+1,lupperstorage)
  endif
  subsparse%ia=0
  nel=1
  un=0
  do i=startdim1,enddim1
   un=un+subsparse%ia(nel)
   nel=nel+1
   do j=sparse%ia(i),sparse%ia(i+1)-1
    k=sparse%ja(j)
    if((k-startdim2+1.ge.i-startdim1+1).and.k.ge.startdim2.and.k.le.enddim2)then
     subsparse%ia(nel)=subsparse%ia(nel)+1
     subsparse%ja(un+subsparse%ia(nel))=k-startdim2+1
     subsparse%a(un+subsparse%ia(nel))=sparse%a(j)
    endif
   enddo
  enddo
  subsparse%ia(1)=1
  do i=2,subsparse%dim1+1
   subsparse%ia(i)=subsparse%ia(i)+subsparse%ia(i-1)
  enddo
 endif

end function

!FINAL
subroutine deallocate_scal_crs(sparse)
 type(crssparse),intent(inout)::sparse

 call sparse%destroy()

end subroutine

subroutine deallocate_rank1_crs(sparse)
 type(crssparse),intent(inout)::sparse(:)

 integer(kind=int32)::i

 do i=1,size(sparse)
  call sparse(i)%destroy()
 enddo

end subroutine

!!!!!!!!!!!!!!!!!!!!!!!LINKED LIST!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
!**CONSTRUCTOR
function constructor_ll(m,n,lupper,unlog) result(sparse)
 type(llsparse)::sparse
 integer(kind=int32),intent(in)::m
 integer(kind=int32),intent(in),optional::n,unlog
 logical,intent(in),optional::lupper

 call sparse%initialize('LINKED LIST',m,m)

 if(present(n))sparse%dim2=n
 if(present(lupper))sparse%lupperstorage=lupper
 if(present(unlog))sparse%unlog=unlog

 sparse%lsymmetric=.false.

 allocate(sparse%heads(sparse%dim1))

end function

!FINAL
subroutine deallocate_scal_ll(sparse)
 type(llsparse),intent(inout)::sparse

 call sparse%destroy()

end subroutine

subroutine deallocate_rank1_ll(sparse)
 type(llsparse),intent(inout)::sparse(:)

 integer(kind=int32)::i

 do i=1,size(sparse)
  call sparse(i)%destroy()
 enddo

end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!METIS GRAPH DATA STRUCTURE!!!!!!!!!!!!!!!!!!!!!!!!!aaa
!**CONSTRUCTOR
function constructor_metisgraph(n,m,unlog) result(metis)
 type(metisgraph)::metis
 integer(kind=int32),intent(in)::n,m
 integer(kind=int32),intent(in),optional::unlog

 metis%unlog=6
 if(present(unlog))metis%unlog=unlog

 metis%nvertices=n
 metis%medges=m
 allocate(metis%xadj(metis%nvertices+1),metis%adjncy(2*metis%medges))
 metis%xadj=0
 metis%adjncy=0
 metis%vwgt=c_null_ptr
 metis%adjwgt=c_null_ptr

end function

!**DESTROY
subroutine destroy_metisgraph(metis)
 class(metisgraph),intent(inout)::metis

 metis%unlog=6
 metis%nvertices=-1
 metis%medges=-1
 metis%vwgt=c_null_ptr
 metis%adjwgt=c_null_ptr
 if(allocated(metis%xadj))deallocate(metis%xadj)
 if(allocated(metis%adjncy))deallocate(metis%adjncy)

end subroutine

!FINAL
subroutine deallocate_scal_metisgraph(metis)
 type(metisgraph),intent(inout)::metis

 call metis%destroy()

end subroutine

subroutine deallocate_rank1_metisgraph(metis)
 type(metisgraph),intent(inout)::metis(:)

 integer(kind=int32)::i

 do i=1,size(metis)
  call metis(i)%destroy()
 enddo

end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!OTHER!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!aaa
!CONVERSIONS
subroutine convertfromlltocoo(othersparse,sparse)
 type(coosparse),intent(out)::othersparse
 type(llsparse),intent(in),target::sparse

 integer(kind=int32)::i
 type(ptrnode),pointer::cursor

 othersparse=coosparse(sparse%dim1,sparse%dim2,sparse%nonzero(),sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 do i=1,sparse%dim1
  cursor=>sparse%heads(i)
  do while(associated(cursor%p))
   call othersparse%add(i,cursor%p%col,cursor%p%val)
   cursor=>cursor%p%next
  enddo
 enddo

! call othersparse%print()

end subroutine

subroutine convertfromlltocrs(othersparse,sparse)
 type(crssparse),intent(out)::othersparse
 type(llsparse),intent(in),target::sparse

 integer(kind=int32)::i,nel,col
 integer(kind=int32),allocatable::rowpos(:)
 type(ptrnode),pointer::cursor
 logical::lsquare

 if(sparse%nonzero().ge.2_int64**31)then
  write(sparse%unlog,'(a)')' ERROR: impossible conversion due a too large number of non-zero elements'
  error stop
 endif

 !Condition: all rows contain at least one element (diagonal element if square or one dummy entry in the last column if needed)

 !Number of elements=number of rows+number off-diagonal elements
 !from sparse
 lsquare=sparse%issquare()

 allocate(rowpos(sparse%dim1))
 rowpos=0
 if(lsquare)then
  do i=1,sparse%dim1
   cursor=>sparse%heads(i)
   do while(associated(cursor%p))
    if(i.ne.cursor%p%col)rowpos(i)=rowpos(i)+1
    cursor=>cursor%p%next
   enddo
  enddo
 else
  do i=1,sparse%dim1
   cursor=>sparse%heads(i)
   do while(associated(cursor%p))
    if(cursor%p%col.ne.sparse%dim2)rowpos(i)=rowpos(i)+1
    cursor=>cursor%p%next
   enddo
  enddo
 endif

 nel=sparse%dim1+sum(rowpos)

 othersparse=crssparse(sparse%dim1,nel,sparse%dim2,sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 !if(othersparse%ia(othersparse%dim1+1).ne.0)othersparse%ia=0

 !determine the number of non-zero off-diagonal elements per row
 othersparse%ia(2:othersparse%dim1+1)=rowpos

 !accumulate the number of elements and add diagonal elements
 othersparse%ia(1)=1
 if(lsquare)then
  do i=1,sparse%dim1
   othersparse%ia(i+1)=othersparse%ia(i+1)+1+othersparse%ia(i)
   othersparse%ja(othersparse%ia(i))=i
  enddo
 else
  do i=1,sparse%dim1
   othersparse%ia(i+1)=othersparse%ia(i+1)+1+othersparse%ia(i)
   othersparse%ja(othersparse%ia(i))=sparse%dim2
  enddo
 endif

 !add the non-zero elements to crs (othersparse)
 !allocate(rowpos(othersparse%dim1))
 rowpos=othersparse%ia(1:othersparse%dim1)
 if(lsquare)then
  do i=1,sparse%dim1
   cursor=>sparse%heads(i)
   do while(associated(cursor%p))
    col=cursor%p%col
    if(i.eq.col)then
     othersparse%a(othersparse%ia(i))=cursor%p%val
    else
     rowpos(i)=rowpos(i)+1
     othersparse%ja(rowpos(i))=col
     othersparse%a(rowpos(i))=cursor%p%val
    endif
    cursor=>cursor%p%next
   enddo
  enddo
 else
  do i=1,sparse%dim1
   cursor=>sparse%heads(i)
   do while(associated(cursor%p))
    col=cursor%p%col
    if(col.eq.sparse%dim2)then
     othersparse%a(othersparse%ia(i))=cursor%p%val
    else
     rowpos(i)=rowpos(i)+1
     othersparse%ja(rowpos(i))=col
     othersparse%a(rowpos(i))=cursor%p%val
    endif
    cursor=>cursor%p%next
   enddo
  enddo
 endif

 deallocate(rowpos)

! call othersparse%print()

end subroutine

subroutine convertfromcootocrs(othersparse,sparse)
 type(crssparse),intent(out)::othersparse
 type(coosparse),intent(in)::sparse

 integer(kind=int32)::i,nel,row,col
 integer(kind=int32),allocatable::rowpos(:)
 integer(kind=int64)::i8
 logical::lsquare

 if(sparse%nonzero().ge.2_int64**31)then
  write(sparse%unlog,'(a)')' ERROR: impossible conversion due to a too large number of non-zero elements'
  stop
 endif

 !Condition: all rows contain at least one element (diagonal element if square or one dummy entry in the last column if needed)

 !Number of elements=number of rows+number off-diagonal elements
 !from sparse
 lsquare=sparse%issquare()

 allocate(rowpos(sparse%dim1))
 rowpos=0

 if(lsquare)then
  do i8=1_int64,sparse%nel
   row=sparse%ij(1,i8)
   if(row.ne.0.and.row.ne.sparse%ij(2,i8))then
    rowpos(row)=rowpos(row)+1
   endif
  enddo
 else
  do i8=1_int64,sparse%nel
   row=sparse%ij(1,i8)
   if(row.ne.0.and.sparse%ij(2,i8).ne.sparse%dim2)then
    rowpos(row)=rowpos(row)+1
   endif
  enddo
 endif

 nel=sparse%dim1+sum(rowpos)

 !othersparse=crssparse(sparse%dim1,nel,sparse%dim2,sparse%lupperstorage)
 call othersparse%init(sparse%dim1,nel,sparse%dim2,sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 !if(othersparse%ia(othersparse%dim1+1).ne.0)othersparse%ia=0

 !determine the number of non-zero off-diagonal elements per row
 othersparse%ia(2:othersparse%dim1+1)=rowpos

 !accumulate the number of elements and add diagonal elements
 othersparse%ia(1)=1
 if(lsquare)then
  do i=1,sparse%dim1
   othersparse%ia(i+1)=othersparse%ia(i+1)+1+othersparse%ia(i)
   othersparse%ja(othersparse%ia(i))=i   !set diagonal element for the case it would not be present
  enddo
 else
  do i=1,sparse%dim1
   othersparse%ia(i+1)=othersparse%ia(i+1)+1+othersparse%ia(i)
   othersparse%ja(othersparse%ia(i))=sparse%dim2   !set last element for the case it would not be present
  enddo
 endif

 !add the non-zero elements to crs (othersparse)
 !allocate(rowpos(othersparse%dim1))
 rowpos=othersparse%ia(1:othersparse%dim1)
 if(lsquare)then
  do i8=1_int64,sparse%nel
   row=sparse%ij(1,i8)
   if(row.gt.0)then
    col=sparse%ij(2,i8)
    if(col.eq.row)then
     othersparse%a(othersparse%ia(row))=sparse%a(i8)
    else
     rowpos(row)=rowpos(row)+1
     othersparse%ja(rowpos(row))=col
     othersparse%a(rowpos(row))=sparse%a(i8)
    endif
   endif
  enddo
 else
  do i8=1_int64,sparse%nel
   row=sparse%ij(1,i8)
   if(row.gt.0)then
    col=sparse%ij(2,i8)
    if(col.eq.sparse%dim2)then
     othersparse%a(othersparse%ia(row))=sparse%a(i8)
    else
     rowpos(row)=rowpos(row)+1
     othersparse%ja(rowpos(row))=col
     othersparse%a(rowpos(row))=sparse%a(i8)
    endif
   endif
  enddo
 endif

 deallocate(rowpos)

! call othersparse%print()

end subroutine

subroutine convertfromcootoll(othersparse,sparse)
 type(llsparse),intent(out)::othersparse
 type(coosparse),intent(in)::sparse

 integer(kind=int32)::row
 integer(kind=int64)::i8

 othersparse=llsparse(sparse%dim1,sparse%dim2,sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 do i8=1_int64,sparse%nel
  row=sparse%ij(1,i8)
  if(row.ne.0)then
   call othersparse%add(row,sparse%ij(2,i8),sparse%a(i8))
  endif
 enddo

! call othersparse%print()

end subroutine

subroutine convertfromcrstocoo(othersparse,sparse)
 type(coosparse),intent(out)::othersparse
 type(crssparse),intent(in)::sparse

 integer(kind=int32)::i,j

 othersparse=coosparse(sparse%dim1,sparse%dim2,sparse%nonzero(),sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 do i=1,sparse%dim1
  do j=sparse%ia(i),sparse%ia(i+1)-1
   call othersparse%add(i,sparse%ja(j),sparse%a(j))
  enddo
 enddo

! call othersparse%print()

end subroutine

subroutine convertfromcrstoll(othersparse,sparse)
 type(llsparse),intent(out)::othersparse
 type(crssparse),intent(in)::sparse

 integer(kind=int32)::i,j

 othersparse=llsparse(sparse%dim1,sparse%dim2,sparse%lupperstorage)

 call othersparse%setsymmetric(sparse%lsymmetric)

 if(allocated(sparse%perm))allocate(othersparse%perm,source=sparse%perm)

 do i=1,sparse%dim1
  do j=sparse%ia(i),sparse%ia(i+1)-1
   call othersparse%add(i,sparse%ja(j),sparse%a(j))
  enddo
 enddo

! call othersparse%print()

end subroutine

subroutine convertfromcrstometisgraph(metis,sparse)
 type(metisgraph),intent(out)::metis
 type(crssparse),intent(in)::sparse

 integer(kind=int32)::i,j,k
 integer(kind=int32)::n,nvertices,medges
 integer(kind=int32),allocatable::rowpos(:)

 if(.not.sparse%lupperstorage.or..not.sparse%issquare())then
  write(sparse%unlog,'(a)')' ERROR: the CRS matrix must be square and upper triangular stored'
  stop
 endif

 n=sparse%getdim(1)
 nvertices=n

 medges=sparse%nonzero()-n  !number of off-diagonal elements

 !metis=metisgraph(nvertices,medges,unlog=sparse%unlog)
 call metis%init(nvertices,medges,unlog=sparse%unlog)

 allocate(rowpos(n))
 rowpos=0
 do i=1,n
  do j=sparse%ia(i),sparse%ia(i+1)-1
   k=sparse%ja(j)
   if(i.ne.k)then
    rowpos(i)=rowpos(i)+1
    rowpos(k)=rowpos(k)+1
   endif
  enddo
 enddo

 metis%xadj(1)=1
 do i=1,n
  metis%xadj(i+1)=metis%xadj(i)+rowpos(i)
 enddo

 rowpos=0
 do i=1,n
  do j=sparse%ia(i),sparse%ia(i+1)-1
   k=sparse%ja(j)
   if(i.ne.k)then
     metis%adjncy(metis%xadj(i)+rowpos(i))=k
     metis%adjncy(metis%xadj(k)+rowpos(k))=i
     rowpos(i)=rowpos(i)+1
     rowpos(k)=rowpos(k)+1
   endif
  enddo
 enddo

end subroutine
end module


! { dg-do run }
!
! PR 39630: [F03] Procedure Pointer Components with PASS
!
! taken from "The Fortran 2003 Handbook" (Adams et al., 2009)

module passed_object_example

  type t
    real :: a
    procedure(print_me), pointer, pass(arg) :: proc
  end type t

contains

  subroutine print_me (arg, lun)
    class(t), intent(in) :: arg
    integer, intent(in) :: lun
    if (abs(arg%a-2.718)>1E-6) STOP 1
    write (lun,*) arg%a
  end subroutine print_me

  subroutine print_my_square (arg, lun)
    class(t), intent(in) :: arg
    integer, intent(in) :: lun
    if (abs(arg%a-2.718)>1E-6) STOP 2
    write (lun,*) arg%a**2
  end subroutine print_my_square

end module passed_object_example

program main
  use passed_object_example
  use iso_fortran_env, only: output_unit

  type(t) :: x

  x%a = 2.718
  x%proc => print_me
  call x%proc (output_unit)
  x%proc => print_my_square
  call x%proc (output_unit)

end program main


! @@name:	teams.2f
! @@type:	F-free
! @@compilable:	yes
! @@linkable:	no
! @@expect:	success
function dotprod(B,C,N, block_size, num_teams, block_threads) result(sum)
implicit none
    real    :: B(N), C(N), sum
    integer :: N, block_size, num_teams, block_threads, i, i0
    sum = 0.0e0
    !$omp target map(to: B, C)
    !$omp teams num_teams(num_teams) thread_limit(block_threads) &
    !$omp&  reduction(+:sum)
    !$omp distribute
       do i0=1,N, block_size
          !$omp parallel do reduction(+:sum)
          do i = i0, min(i0+block_size,N)
             sum = sum + B(i) * C(i)
          end do
       end do
    !$omp end teams
    !$omp end target
end function