!> Module containing subroutines for sparse inverses of symmetric positive definite matrices

!> @todo Still raw and not very efficient

!Based on Karin Meyer 's code !(didgeridoo.une.edu.au/womwiki/doku.php?id=fortran:fortran)
!Rewritten for my purposes

module modspainv
#if (_DP==0)
 use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real32
 use modsparse_mkl, only: spotrf, spotri, strsm, ssymm, sgemm
#else
 use iso_fortran_env,only:output_unit,int32,int64,real32,real64,wp=>real64
 use modsparse_mkl, only: dpotrf, dpotri, dtrsm, dsymm, dgemm
#endif
 use modcommon
 !$ use omp_lib
 implicit none
 private
 public::get_chol,get_ichol,get_spainv

 integer(kind=int32),parameter::minsizesupernode=0  !values other than 0 (e.g., 256) may give troubles
 real(kind=wp),parameter::tol=1.e-10_wp

 interface get_chol
  module procedure get_chol_crs
 end interface

 interface get_ichol
  module procedure get_ichol_crs
 end interface

 interface get_spainv
  module procedure get_spainv_crs
 end interface

 interface
  subroutine smbfct(neqns,xadj,adjncy,perm,invp,&
              xlnz,maxlnz,xnzsub,nzsub,maxsub,&
              rchlnk,mrglnk,marker,flag&
              )
   integer::neqns
   integer::maxsub,flag,maxlnz
   integer::xadj(*),adjncy(*)
   integer::perm(*),invp(*)
   integer::xlnz(*),xnzsub(*),nzsub(*),rchlnk(*),mrglnk(*),marker(*)
  end subroutine
 end interface

contains

!PUBLIC
!Should return the Cholesky factor in the permuted order
subroutine get_ichol_crs(ia,ja,a,xadj,adjncy,perm,minsizenode,un)
 integer(kind=int32),intent(inout)::ia(:)
 integer(kind=int32),intent(inout)::ja(:)
 integer(kind=int32),intent(in)::xadj(:),adjncy(:)
 integer(kind=int32),intent(in)::perm(:)  !Ap(i,:)=A(perm(i),:)
 integer(kind=int32),intent(in),optional::minsizenode
 integer(kind=int32),intent(in),optional::un
 real(kind=wp),intent(inout)::a(:)

 integer(kind=int32)::unlog,neqns
 integer(kind=int32)::mssn
 integer(kind=int32),allocatable::xlnz(:),xnzsub(:),nzsub(:)
 real(kind=wp),allocatable::xspars(:),diag(:)
 !$ real(kind=real64)::t1
 real(kind=real64)::time(6)

 mssn=minsizesupernode
 if(present(minsizenode))mssn=minsizenode

 unlog=output_unit
 if(present(un))unlog=un

 time=0._real64

 neqns=size(ia)-1

 call get_ichol_spainv_crs(neqns,ia,ja,a,xadj,adjncy,perm,.false.,xlnz,xspars,xnzsub,nzsub,diag,mssn,time)

 ! Cholesky factorization
 !Convert to ija
 !$ t1=omp_get_wtime()
 call converttoija_noperm(neqns,xlnz,xspars,xnzsub,nzsub,diag,ia,ja,a,perm)
 !$ time(6)=omp_get_wtime()-t1

 call writetime(unlog,time,'SPARSE CHOL FACT.')

end subroutine

subroutine get_chol_crs(ia,ja,a,xadj,adjncy,perm,minsizenode,un)
 integer(kind=int32),intent(inout),allocatable::ia(:)
 integer(kind=int32),intent(inout),allocatable::ja(:)
 integer(kind=int32),intent(in)::xadj(:),adjncy(:)
 integer(kind=int32),intent(in)::perm(:)  !Ap(i,:)=A(perm(i),:)
 integer(kind=int32),intent(in),optional::minsizenode
 integer(kind=int32),intent(in),optional::un
 real(kind=wp),intent(inout),allocatable::a(:)

 integer(kind=int32)::unlog,neqns
 integer(kind=int32)::mssn
 integer(kind=int32),allocatable::xlnz(:),xnzsub(:),nzsub(:)
 real(kind=wp),allocatable::xspars(:),diag(:)
 !$ real(kind=real64)::t1
 real(kind=real64)::time(6)

 mssn=minsizesupernode
 if(present(minsizenode))mssn=minsizenode

 unlog=output_unit
 if(present(un))unlog=un

 time=0._real64

 neqns=size(ia)-1

 call get_ichol_spainv_crs(neqns,ia,ja,a,xadj,adjncy,perm,.false.,xlnz,xspars,xnzsub,nzsub,diag,mssn,time)

 !Convert to ija
 !$ t1=omp_get_wtime()
 call convertfactortoija(neqns,xlnz,xspars,xnzsub,nzsub,diag,ia,ja,a)
 !$ time(6)=omp_get_wtime()-t1

 call writetime(unlog,time,'CHOL FACT.')

end subroutine

subroutine get_spainv_crs(ia,ja,a,xadj,adjncy,perm,minsizenode,un)
 integer(kind=int32),intent(in)::ia(:)
 integer(kind=int32),intent(in)::ja(:)
 integer(kind=int32),intent(in)::xadj(:),adjncy(:)
 integer(kind=int32),intent(inout)::perm(:)  !Ap(i,:)=A(perm(i),:)
 integer(kind=int32),intent(in),optional::minsizenode
 integer(kind=int32),intent(in),optional::un
 real(kind=wp),intent(inout)::a(:)

 integer(kind=int32)::unlog,neqns
 integer(kind=int32)::mssn
 integer(kind=int32),allocatable::xlnz(:),xnzsub(:),nzsub(:)
 real(kind=wp),allocatable::xspars(:),diag(:)
 !$ real(kind=real64)::t1
 real(kind=real64)::time(6)

 mssn=minsizesupernode
 if(present(minsizenode))mssn=minsizenode

 unlog=output_unit
 if(present(un))unlog=un

 time=0._real64

 neqns=size(ia)-1

 call get_ichol_spainv_crs(neqns,ia,ja,a,xadj,adjncy,perm,.true.,xlnz,xspars,xnzsub,nzsub,diag,mssn,time)

 !Convert to ija
 !$ t1=omp_get_wtime()
 call converttoija(neqns,xlnz,xspars,xnzsub,nzsub,diag,ia,ja,a,perm)
 !$ time(6)=omp_get_wtime()-t1

 call writetime(unlog,time,'INVERSION')

end subroutine

subroutine get_ichol_spainv_crs(neqns,ia,ja,a,xadj,adjncy,perm,lspainv,xlnz,xspars,xnzsub,nzsub,diag,mssn,time)
 integer(kind=int32),intent(in)::neqns
 integer(kind=int32),intent(inout)::mssn
 integer(kind=int32),intent(in)::ia(:)
 integer(kind=int32),intent(in)::ja(:)
 integer(kind=int32),intent(in)::xadj(:),adjncy(:)
 integer(kind=int32),intent(in)::perm(:)  !Ap(i,:)=A(perm(i),:)
 real(kind=wp),intent(inout)::a(:)
 real(kind=real64),intent(inout)::time(:)
 logical,intent(in)::lspainv

 integer(kind=int32),allocatable,intent(out)::xlnz(:),xnzsub(:),nzsub(:)
 real(kind=wp),allocatable,intent(out)::xspars(:),diag(:)

#if (_VERBOSE >2)
 integer(kind=int32)::i
#endif
 integer(kind=int32)::nnode
 integer(kind=int32)::maxnode
 integer(kind=int32)::maxsub,flag,maxlnz
 integer(kind=int32)::rank
 integer(kind=int32),allocatable::inode(:)
!$ real(kind=real64)::t1

 !symbolic factorization
 !$ t1=omp_get_wtime()
 call symbolicfact(neqns,ia(neqns+1)-1,xadj,adjncy,perm,xlnz,maxlnz,xnzsub,nzsub,maxsub,flag)
 !$ time(1)=omp_get_wtime()-t1
 !$ t1=omp_get_wtime()
#if (_VERBOSE >0)
 !$ write(*,'(1x,a,t30,a,g0)')'CRS Symb. fact.',': Elapsed time = ',time(1)
#endif

 call computexsparsdiag(neqns,ia,ja,a,xlnz,nzsub,xnzsub,maxlnz,xspars,diag,perm)
 !$ time(2)=omp_get_wtime()-t1
 !$ t1=omp_get_wtime()
#if (_VERBOSE >0)
 !$ write(*,'(1x,a,t30,a,g0)')'CRS Compute xspars',': Elapsed time = ',time(2)
#endif

 !super following Karin Meyer
 allocate(inode(neqns+1))  !to allow diagonal matrices (for which the number of super-nodes is equal to the number of equations
 call super_nodes(mssn,neqns,xlnz,xnzsub,nzsub,nnode,inode,maxnode)
 !$ time(3)=omp_get_wtime()-t1
 !$ t1=omp_get_wtime()
#if (_VERBOSE >0)
 !$ write(*,'(1x,a,t30,a,g0)')'CRS Super nodes',': Elapsed time = ',time(3)
#endif

 ! Cholesky factorization
 call super_gsfct(neqns,xlnz,xspars,xnzsub,nzsub,diag,nnode,inode,rank)
 !$ time(4)=omp_get_wtime()-t1
 !$ t1=omp_get_wtime()
#if (_VERBOSE >0)
 !$ write(*,'(1x,a,t30,a,g0)')'CRS Chol. fact.',': Elapsed time = ',time(4)
#endif

 if(lspainv)then
  ! Matrix inverse
  call super_sparsinv(neqns,xlnz,xspars,xnzsub,nzsub,diag,nnode,inode)
  !$ time(5)=omp_get_wtime()-t1
  !$ t1=omp_get_wtime()
#if (_VERBOSE >0)
  !$ write(*,'(1x,a,t30,a,g0)')'CRS Inversion',': Elapsed time = ',time(5)
#endif
 endif

#if (_VERBOSE >0)
 write(*,'(/2x,a,i0)')'Flag symbolic factorization    : ',flag
 !write(*,'(2x,a,i0)')'Number of non-zero in the facor: ',maxlnz
 write(*,'(2x,a,i0)')'Number of super-nodes          : ',nnode
 write(*,'(2x,a,i0)')'Min size of super-nodes        : ',mssn
 write(*,'(2x,a,i0)')'Max size of super-nodes        : ',maxnode
 write(*,'(2x,a,i0/)')'Rank of the matrix             : ',rank
#endif
#if (_VERBOSE >2)
 do i=1,nnode
  write(*,'(1x,4(a,i8))') 'node',i,' from row', inode(i+1)+1,'  to row', inode(i),' size ',inode(i)-inode(i+1)
 end do
#endif

end subroutine

!PRIVATE
subroutine symbolicfact(neqns,nnzeros,xadj,adjncy,perm,xlnz,maxlnz,xnzsub,nzsub,maxsub,flag)
 integer(kind=int32),intent(in)::neqns,nnzeros
 integer(kind=int32),intent(in)::xadj(:),adjncy(:),perm(:)
 integer(kind=int32),intent(out)::maxlnz,maxsub,flag
 integer(kind=int32),allocatable,intent(out)::xlnz(:),xnzsub(:),nzsub(:)

 integer(kind=int32)::i,maxsubinit
 integer(kind=int32),allocatable::invp(:),rchlnk(:),mrglnk(:),marker(:)

 allocate(invp(size(perm)))
 do i=1,size(perm)
  invp(perm(i))=i
 enddo

 allocate(xlnz(neqns+1),xnzsub(neqns+1))
 allocate(rchlnk(neqns),mrglnk(neqns),marker(neqns))
 xlnz=0
 xnzsub=0
 rchlnk=0
 mrglnk=0
 marker=0
 !maxsub=ia(neqns+1)-1
 maxsub=nnzeros

 do
  flag=0
  maxsubinit=maxsub
  if(allocated(nzsub))deallocate(nzsub)
  allocate(nzsub(maxsub))
  nzsub=0
  call smbfct(neqns,xadj,adjncy,perm,invp,xlnz,maxlnz,xnzsub,nzsub,maxsub,&
              rchlnk,mrglnk,marker,flag&
              )
  if(maxsub.ne.maxsubinit)cycle
  if(flag.eq.0)exit
  maxsub=maxsub*2
 enddo
 deallocate(rchlnk,mrglnk,marker)

end subroutine

subroutine super_nodes(mssn, neqns, xlnz, xnzsub, ixsub, nnode, inode,maxnode)
 integer(kind=int32),intent(inout)::mssn
 integer(kind=int32),intent(in)::neqns
 integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:)
 integer(kind=int32),intent(out)::nnode
 integer(kind=int32),intent(out)::maxnode
 integer(kind=int32),intent(out)::inode(:) !size=neqns+1

 integer(kind=int32)::i,ii,j,n,ilast,kk
 integer(kind=int32)::minnode
 real(kind=wp)::xx

 ! establish boundaries between diaggonal blocks 100% full
 ilast = neqns
 nnode = 0
 minnode=2**30
 maxnode=0
 do i = neqns-1, 1, -1
    ii = xnzsub(i)
    n = 0
    do j = xlnz(i), xlnz(i+1)-1
       kk = ixsub(ii)
       ii = ii + 1
       if(  kk > ilast ) exit
       n = n + 1
    end do
    xx = dble( n ) / dble( ilast - i )
    if( xx < 1._wp .and. (ilast-i).ge.mssn ) then
     nnode = nnode +1
     minnode=min(minnode,ilast-i)
     maxnode=max(maxnode,ilast-i)
     inode(nnode) = ilast
     ilast = i
    end if
 end do
 nnode = nnode +1
 inode(nnode) = ilast
 inode(nnode+1) = 0

 mssn=minnode

end subroutine

subroutine super_gsfct(neqns,xlnz,xspars,xnzsub,ixsub,diag,nnode,inode,rank)
 integer(kind=int32),intent(in)::neqns,nnode
 integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:),inode(:)
 integer(kind=int32),intent(out),optional::rank
 real(kind=wp),intent(inout)::xspars(:),diag(:)

 integer(kind=int32)::i,j,jrow,n,ksub,irow,jnode,icol1,icol2,jcol,ii,jj,mm,kk
#if (_VERBOSE>0)
 integer(kind=int32)::ninit
#endif
 integer(kind=int32)::orank
 integer(kind=int32),allocatable::jvec(:),kvec(:)
 real(kind=wp),allocatable::ttt(:,:),s21(:,:),s22(:,:)
! real(kind=wp),allocatable::ttt1(:,:)   !aaaa
 logical::lpos

 write(output_unit,'(/" Cholesky factorization...")')

 allocate(jvec(neqns),kvec(neqns),stat=ii)
 if(ii.ne.0)call alloc_err(__LINE__,__FILE__)

 jvec=0 !it must be re-initialized to 0 only if it is modified, i.e, when n.gt.0
#if (_VERBOSE>0)
 ninit=0
#endif
 orank=0

 do jnode = nnode, 1, -1
  icol1 = inode(jnode+1) + 1
  icol2 = inode(jnode)
  mm = icol2 - icol1 +1

  call progress(icol2,neqns)

  !pick out diagonal block
  allocate( ttt(icol1:icol2,icol1:icol2), stat = ii )
  if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
  ttt=0._wp
  !jvec=0
  n=0
  do irow = icol1, icol2
   ttt(irow,irow) = diag(irow)
   ksub = xnzsub(irow)
   do i = xlnz(irow), xlnz(irow+1)-1
    jcol = ixsub(ksub)
    ksub = ksub + 1
    if( jcol <= icol2 ) then
     ttt(jcol,irow) = xspars(i)
    else
     if(jvec(jcol).eq.0)then
      n=n+1
      jvec(jcol)=n
      kvec(n)=jcol
     endif
    end if
   end do
  end do

  !factorise

  lpos=.true.
  irow=mm
  if(irow.eq.1)then
   if(ttt(icol1,icol1).gt.0._wp)then
    ttt=sqrt(ttt)
   else
    lpos=.false.
    ttt=0._wp
    irow=0
   endif
  else
#if(_DP==0)
   call spotrf('L',mm,ttt,mm,ii)
#else
   call dpotrf('L',mm,ttt,mm,ii)
#endif
   if(ii.ne.0)then
    write(*,'(a,i0,a)')'Routine DPOTRF returned error code: ',ii,' (matrix is not positive definite)'
    error stop
   endif
  endif
  orank=orank+irow

  !adjust block below diagonal
  if(n.gt.0)then
         !... pick out rows
         allocate( s21(n, icol1:icol2), stat = ii )
         if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
         s21 = 0._wp
         do irow = icol1, icol2
            ksub = xnzsub(irow)
            do i = xlnz(irow), xlnz(irow+1)-1
               jcol = ixsub(ksub)
               ksub = ksub + 1
               if( jcol <= icol2 ) cycle
               jj = jvec(jcol)
               s21(jj,irow) = xspars(i)
            end do
         end do

         !calculate L21
   if(lpos)then
#if(_DP==0)
    call strsm( 'R', 'L', 'T', 'N', n, mm, 1._wp, ttt, mm, s21, n )
   else
    call sgtrsm( 'R', 'L', 'T', 'N', n, mm, 1._wp, ttt, mm, s21, n )
#else
    call dtrsm( 'R', 'L', 'T', 'N', n, mm, 1._wp, ttt, mm, s21, n )
   else
    call dgtrsm( 'R', 'L', 'T', 'N', n, mm, 1._wp, ttt, mm, s21, n )
#endif
   endif
         !adjust remaining triangle to right: A22 := A22 - L21 L21'
         allocate( s22(n,n), stat = ii )
         if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
#if(_DP==0)
         call ssyrk( 'L', 'N', n, mm, 1._wp, s21, n, 0._wp, s22, n )
#else
!         call dsyrk( 'L', 'N', n, mm, 1._wp, s21, n, 0._wp, s22, n )
block      !aaaaaaaaaaaaaa !to be checked
real(kind=wp)::tmp
         do j=1,n
          s22(:,j)=0._wp
          do ii=icol1,icol2
           if(s21(j,ii).ne.0._wp)then
            tmp=s21(j,ii)
            do i=j,n
             s22(i,j)=s22(i,j)+tmp*s21(i,ii)
            enddo
           endif
          enddo
         enddo
end block
#endif
         kk = maxval(kvec(1:n))
         do i = 1, n
             jrow = kvec(i)
             diag(jrow) = diag(jrow) - s22(i,i)
             ksub = xnzsub(jrow)
             do j = xlnz(jrow), xlnz(jrow+1)-1
                jcol = ixsub(ksub)
                if( jcol > kk ) exit
                ksub = ksub + 1
                ii = jvec(jcol)
                if( ii > 0 ) then
                 if(ii>i)then
                  xspars(j) = xspars(j) - s22(ii,i)
                 else
                  xspars(j) = xspars(j) - s22(i,ii)
                 endif
                endif
             end do
         end do
         deallocate( s22 )
     end if

     !transfer block back to sparse storage
     do irow = icol1, icol2
       diag(irow) = ttt(irow,irow)
        ksub = xnzsub(irow)
        do i = xlnz(irow), xlnz(irow+1)-1
           jcol = ixsub(ksub)
           ksub = ksub + 1
           if( jcol <= icol2 ) then
               xspars(i) = ttt(jcol,irow)
           else
               xspars(i) = s21( jvec(jcol), irow)
           end if
        end do
     end do

  deallocate( ttt )
  if(n.gt.0)then
   deallocate(s21)
   !jvec=0
   !this should be faster than jvec=0
   do irow = icol1, icol2
    ksub = xnzsub(irow)
    do i = xlnz(irow), xlnz(irow+1)-1
     jcol = ixsub(ksub)
     ksub = ksub + 1
     if( jcol <= icol2 ) then
     else
       jvec(jcol)=0
     end if
    end do
   end do
#if (_VERBOSE>0)
   ninit=ninit+1
#endif
  endif

 enddo ! jnode

 !zeroing columns for positive semi-definite matrix
 do irow=neqns,1,-1
  if(diag(irow).lt.tol)then
   jvec(irow)=1
  endif
  ksub = xnzsub(irow)
  do i = xlnz(irow), xlnz(irow+1)-1
   jcol = ixsub(ksub)
   ksub = ksub + 1
   if(jvec(jcol).ne.0)xspars(i)=0._wp
  end do
 end do

 deallocate(jvec,kvec)

 if(present(rank))rank=orank

#if (_VERBOSE>0)
 write(*,'(a,i0)')' Number of zeroing a large vector (jvec): ',ninit
#endif

end subroutine

subroutine super_sparsinv(neqns,xlnz,xspars,xnzsub,ixsub,diag,nnode,inode)
  integer(kind=int32),intent(in)::neqns,nnode
  integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:),inode(:)
  real(kind=wp),intent(inout) ::xspars(:),diag(:)

  integer(kind=int32)::irow,ksub,i,k,m,jcol,jrow, jnode, icol2, icol1, ii,jj, mm, n21, iopt
  integer(kind=int32),allocatable::kvec(:),jvec(:)
  real(kind=wp)::xx
  real(kind=wp),dimension(:,:),allocatable:: ttt, s21, s22, f21
  real(kind=wp),dimension(:),allocatable:: rr, qx

  write(output_unit,'(/" Sparse inversion...")')

  allocate( jvec(neqns), kvec(neqns),stat = ii )
  if(ii.ne.0)call alloc_err(__LINE__,__FILE__)

  jvec=0  !placed here and at the end of the loop to avoid to re-initialize it at each iteration and when n21=0

! backwards flops: determine inverse using supernodal blocks
  do jnode = 1, nnode
     icol1 = inode(jnode+1) + 1
     icol2 = inode(jnode)
     mm = icol2 - icol1 +1

   call progress(icol2,neqns)

     !pick out diagonal block
     allocate( ttt(icol1:icol2,icol1:icol2), stat = ii )
     if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
     ttt=0._wp
     !jvec=0
     n21=0
     do irow=icol1,icol2
      ttt(irow,irow)=diag(irow)
      ksub=xnzsub(irow)
      do i=xlnz(irow),xlnz(irow+1)-1
       jcol=ixsub(ksub)
       ksub=ksub+1
       if(jcol<=icol2)then
        ttt(jcol,irow)=xspars(i)
       else
        if(jvec(jcol).eq.0)then
         n21=n21+1
         jvec(jcol)=n21
         kvec(n21)=jcol
        endif
       end if
      end do
     end do

     !pick out lead columns (condensed)
     if( n21 > 0 ) then
         allocate( s21(n21, icol1:icol2), stat = ii )
         if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
         allocate( f21(n21, icol1:icol2), stat = ii )
         if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
         s21 = 0._wp
         f21 = 0._wp
         do irow = icol1, icol2
            ksub = xnzsub(irow)
            do i = xlnz(irow), xlnz(irow+1)-1
               jcol = ixsub(ksub)
               ksub = ksub + 1
               if( jcol <= icol2 ) cycle
               jj = jvec(jcol)
               s21(jj,irow) = xspars(i)
            end do
         end do
!        ... post-multiply with inverse Chol factor -> solve
#if(_DP==0)
         call strsm( 'R', 'L', 'N', 'N', n21, mm, 1._wp, ttt, mm, s21, n21 )
#else
         call dtrsm( 'R', 'L', 'N', 'N', n21, mm, 1._wp, ttt, mm, s21, n21 )
#endif
!        ... invert Cholesky factor
#if(_DP==0)
         call spotri( 'L',  mm, ttt, mm, ii )
#else
         call dpotri( 'L',  mm, ttt, mm, ii )
#endif
         if( ii /= 0 ) then
             write(*,*) 'Routine DPOTRI returned error code', ii
             stop
         end if
!        ... pre-multiply by already inverted submatrix
         iopt = 2
44       if( iopt == 1 ) then
            allocate( rr(icol1:icol2), qx(icol1:icol2), stat = ii )
            if(ii.ne.0)call alloc_err(__LINE__,__FILE__)
            f21 = 0._wp
            do k = 1, n21
               jrow = kvec(k)
               rr = s21(k,:)
               qx =  diag(jrow) * rr
               ksub = xnzsub(jrow)
               do i = xlnz(jrow), xlnz(jrow+1)-1
                  jcol = ixsub(ksub)
                  ksub = ksub + 1
                  m = jvec(jcol)
                  if( m < 1 ) cycle
                  xx = xspars(i)
                  f21(m,:) = f21(m,:) + xx * rr
                  qx = qx + xx * s21(m,:)
               end do
               f21(k,:) = f21(k,:) + qx
            end do
            deallocate( rr, qx )
         else
            allocate( s22(n21,n21), stat = ii )
            if( ii /= 0 ) then
                iopt = 1
                go to 44
            end if
            s22 = 0._wp
            do k = 1, n21
               jrow = kvec(k)
               s22(k,k) = diag(jrow)
               ksub = xnzsub(jrow)
               do i = xlnz(jrow), xlnz(jrow+1)-1
                  jcol = ixsub(ksub)
                  ksub = ksub + 1
                  m = jvec(jcol)
                  if( m > 0 )then
                   if(m>k)then
                    s22(m,k) = xspars(i)
                   else
                    s22(k,m) = xspars(i)
                   endif
                  endif
               end do
            end do
#if(_DP==0)
            call ssymm( 'L', 'L', n21, mm, 1._wp, s22, n21, s21, n21, 0._wp,f21, n21  )
#else
            call dsymm( 'L', 'L', n21, mm, 1._wp, s22, n21, s21, n21, 0._wp,f21, n21  )
#endif
            deallocate( s22 )
         end if
!        ... adjustments to current block
#if(_DP==0)
         call sgemm( 'T', 'N', mm, mm, n21, 1._wp, f21, n21, s21, n21, 1._wp,ttt, mm )
#else
         call dgemm( 'T', 'N', mm, mm, n21, 1._wp, f21, n21, s21, n21, 1._wp,ttt, mm )
#endif
     else
#if(_DP==0)
         call spotri( 'L',  mm, ttt, mm, ii )
#else
         call dpotri( 'L',  mm, ttt, mm, ii )
#endif
         if( ii /= 0 ) then
             write(*,*) 'Routine DPOTRI returned error code', ii
             stop
         end if
     end if

!    save current block
     do irow = icol1, icol2
        diag(irow) = ttt(irow,irow)
        ksub = xnzsub(irow)
        do i = xlnz(irow), xlnz(irow+1)-1
           jcol = ixsub(ksub)
           ksub = ksub + 1
           if( jcol <= icol2 ) then
               xspars(i) = ttt(jcol,irow)
           else
               xspars(i) = - f21(jvec(jcol),irow)
           end if
        end do
     end do

   deallocate( ttt )
   if(n21.gt.0)then
    deallocate(s21,f21)
    jvec=0
   endif

  enddo ! jnode

  deallocate(jvec,kvec)

end subroutine

subroutine computexsparsdiag(neqns,ia,ja,a,xlnz,nzsub,xnzsub,maxlnz,xspars,diag,perm)
 integer(kind=int32),intent(in)::neqns,maxlnz
 integer(kind=int32),intent(in)::ia(:),ja(:)
 integer(kind=int32),intent(in)::perm(:)
 integer(kind=int32),intent(in)::xlnz(:),nzsub(:),xnzsub(:)
 real(kind=wp),intent(in)::a(:)
 real(kind=wp),intent(out),allocatable::xspars(:),diag(:)

 integer(kind=int32)::irow,iirow,icol,i,j,k

 allocate(xspars(maxlnz),diag(neqns))
 xspars=0._wp
 diag=0._wp

 do i=1,neqns
  irow=perm(i)
  diag(i)=a(ia(irow))
  do k=xlnz(i),xlnz(i+1)-1
   iirow=irow
   icol=perm(nzsub(xnzsub(i)+k-xlnz(i)))
   if(iirow.gt.icol)then
    iirow=icol
    icol=irow
   endif
   do j=ia(iirow)+1,ia(iirow+1)-1
    if(ja(j).eq.icol)then
     xspars(k)=a(j)
     exit
    endif
   enddo
  enddo
 enddo

end subroutine

subroutine converttoija(neqns,xlnz,xspars,xnzsub,ixsub,diag,ia,ja,a,perm)
 integer(kind=int32),intent(in)::neqns
 integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:)
 integer(kind=int32),intent(in)::ia(:),ja(:),perm(:)
 real(kind=wp),intent(in)::xspars(:),diag(:)
 real(kind=wp),intent(inout):: a(:)

 integer(kind=int32)::irow,ksub,i,icol
 integer(kind=int32)::pirow,ppirow,picol,ip

 do irow = 1, neqns
  pirow=perm(irow)
  a(ia(pirow))=diag(irow)
  ksub = xnzsub(irow)
  do i = xlnz(irow), xlnz(irow+1)-1
   ppirow=pirow
   icol = ixsub(ksub)
   picol=perm(icol)
   ksub = ksub + 1
   if(ppirow.gt.picol)then
    ppirow=picol
    picol=pirow
   endif
   intloop: do ip=ia(ppirow)+1,ia(ppirow+1)-1
    if(ja(ip).eq.picol)then
     a(ip)=xspars(i)
     exit intloop
    endif
   enddo intloop
  end do
 end do

end subroutine

subroutine converttoija_noperm(neqns,xlnz,xspars,xnzsub,ixsub,diag,ia,ja,a,perm)
 integer(kind=int32),intent(in)::neqns
 integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:)
 integer(kind=int32),intent(in)::perm(:)
 integer(kind=int32),intent(inout)::ia(:),ja(:)
 real(kind=wp),intent(in)::xspars(:),diag(:)
 real(kind=wp),intent(inout):: a(:)

 integer(kind=int32)::irow,ksub,i,icol
 integer(kind=int32)::pirow,ppirow,picol,ip
 integer(kind=int32)::nel
 integer(kind=int32),allocatable::iperm(:)
 integer(kind=int32),allocatable::iia(:),jja(:)

 !inefficient but it works

 !1. Permute ia and ja
 allocate(iperm,source=perm)
 do i=1,neqns
  iperm(perm(i))=i
 enddo
 nel=ia(neqns+1)-1
 allocate(iia(nel),jja(nel))

 do irow=1,neqns
  pirow=iperm(irow)
  do i=ia(irow),ia(irow+1)-1
   if(pirow.lt.iperm(ja(i)))then
    iia(i)=pirow
    jja(i)=iperm(ja(i))
   else
    iia(i)=iperm(ja(i))
    jja(i)=pirow
   endif
  enddo
 enddo

 ia=0
 ia(1)=1
 do i=1,nel
  ia(iia(i)+1)=ia(iia(i)+1)+1
 enddo

 ja=0
 do i=1,neqns
  ia(i+1)=ia(i+1)+ia(i)
  ja(ia(i))=i
 enddo

 iperm=1
 do i=1,nel
  if(iia(i).ne.jja(i))then
   ja(ia(iia(i))+iperm(iia(i)))=jja(i)
   iperm(iia(i))=iperm(iia(i))+1
  endif
 enddo

 !2. Replace a
 a=0._wp
 do irow = 1, neqns
  pirow=irow
  a(ia(pirow))=diag(irow)
  ksub = xnzsub(irow)
  do i = xlnz(irow), xlnz(irow+1)-1
   ppirow=pirow
   icol = ixsub(ksub)
   picol=icol
   ksub = ksub + 1
   if(ppirow.gt.picol)then
    ppirow=picol
    picol=pirow
   endif
   intloop: do ip=ia(ppirow)+1,ia(ppirow+1)-1
    if(ja(ip).eq.picol)then
     a(ip)=xspars(i)
     exit intloop
    endif
   enddo intloop
  end do
 end do

end subroutine

subroutine convertfactortoija(neqns,xlnz,xspars,xnzsub,ixsub,diag,ia,ja,a)
 integer(kind=int32),intent(in)::neqns
 integer(kind=int32),intent(in)::ixsub(:),xlnz(:),xnzsub(:)
 integer(kind=int32),intent(inout)::ia(:)
 integer(kind=int32),intent(inout),allocatable::ja(:)
 real(kind=wp),intent(in)::xspars(:),diag(:)
 real(kind=wp),intent(inout),allocatable::a(:)

 integer(kind=int32)::j,irow,ksub,icol

 deallocate(ja)
 deallocate(a)

 allocate(ja(size(xspars)+neqns))
 allocate(a(size(xspars)+neqns))
 ja=0
 a=0._wp

 do irow=1,neqns
  ia(irow)=xlnz(irow)+irow-1
  ja(ia(irow))=irow
  a(ia(irow))=diag(irow)
  ksub=xnzsub(irow)
  do j=xlnz(irow),xlnz(irow+1)-1
   icol=ixsub(ksub)
   ksub=ksub+1
   ja(j+irow)=icol
   a(j+irow)=xspars(j)
  enddo
 enddo
 ia(neqns+1)=xlnz(neqns+1)+neqns

end subroutine

subroutine writetime(unlog,time,a)
 integer(kind=int32)::unlog
 real(kind=real64),intent(in)::time(:)
 character(len=*),intent(in)::a

 write(unlog,'(/a)')' CRS MATRIX '//trim(a)
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Symbolic factorization',':',time(1),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Setup of tmp arrays',':',time(2),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Node determination',':',time(3),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Cholesky factorization',':',time(4),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Matrix inversion',':',time(5),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Conversion to CRS',':',time(6),' s'
 !$ write(unlog,'(2x,a,t31,a,t33,f0.5,a)')'Total time',':',sum(time),' s'

end subroutine

end module


      FUNCTION FACTLN(N)
      DIMENSION A(100)
      DATA A/100*-1./
      IF (N.LT.0) PAUSE 'negative factorial'
      IF (N.LE.99) THEN
        IF (A(N+1).LT.0.) A(N+1)=GAMMLN(N+1.)
        FACTLN=A(N+1)
      ELSE
        FACTLN=GAMMLN(N+1.)
      ENDIF
      RETURN
      END


program example

	use solver

	implicit none

	integer, dimension (1, 2) :: ele
	double precision, dimension (3, 2) :: X0, U
	double precision, dimension (6, 6) :: C
	logical, dimension (6, 2) :: DOF
	double precision, dimension (6, 2) :: dU, Q, res
	double precision, dimension (1, 6, 1) :: p, f
	double precision, dimension (1, 3, 1) :: om
	double precision, dimension (1, 1, 3, 3) :: rot
	integer, parameter :: MAXITER = 20
	double precision, parameter :: TOLER = 1D-5
	integer :: i, Niter, errck

	ele (1, :) = (/ 1, 2 /)
	X0 (:, 1) = (/ 0.0D1, 0.0D1, 0.0D1 /)
	X0 (:, 2) = (/ 1.0D1, 2.0D1, 3.0D1 /)
	U = 0.0D1
	C = 0.0D1
	do i = 1, 6
		C (i, i) = 1.0D1
	end do
	DOF (:, 1) = .FALSE.
	DOF (:, 2) = .TRUE.
	dU = 0.0D1
	Q = 0.0D1
	Q (2, 2) = 0.001
	p = 0.0D1
	f = 0.0D1
	om = 0.0D1
	rot = 0.0D1
	do i = 1, 3
		rot (1, 1, i, i) = 1
	end do

	call newton_iter (ele, X0, U, C, DOF, dU, Q, p, rot, om, f, res, TOLER, MAXITER, 'RSD', Niter, errck, .TRUE.)

	print *, U (:, 2)
	print *, rot (1, 1, :, :)

end program example


PROGRAM RiemannProblem1D_NuclearEOS

  USE KindModule, ONLY: &
    DP
  USE UnitsModule, ONLY: &
    Centimeter, &
    Kilometer, &
    Gram, &
    Second, &
    Millisecond, &
    Microsecond, &
    Erg
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE RiemannProblemInitializationModule, ONLY: &
    InitializeRiemannProblem1D
  USE TimeSteppingModule, ONLY: &
    EvolveFields, &
    SSP_RK

  IMPLICIT NONE

  REAL(DP) :: StartTime

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'RiemannProblem1D_NuclearEOS', &
           nX_Option &
             = [ 128, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 2, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ] * Kilometer, &
           xR_Option &
             = [ 1.0_DP, 1.0_DP, 1.0_DP ] * Kilometer, &
           nNodes_Option &
             = 3, &
           ActivateUnits_Option &
             = .TRUE., &
           EquationOfState_Option &
             = 'TABLE', &
           EquationOfStateTableName_Option &
             = 'EquationOfStateTable.h5', &
           FluidSolver_Option &
             = 'Euler_DG', &
           FluidRiemannSolver_Option &
             = 'HLLC', &
           EvolveFluid_Option &
             = .TRUE., &
           ApplySlopeLimiter_Option &
             = .TRUE., &
           BetaTVB_Option &
             = 0.0d2, &
           BetaTVD_Option &
             = 1.8d0, &
           ApplyPositivityLimiter_Option &
             = .TRUE., &
           nStages_SSP_RK_Option &
             = 3 )

  CALL InitializeRiemannProblem1D &
         ( D_L  = 1.00d12 * Gram / Centimeter**3, &
           V_L  = [ 0.0_DP, 0.0_DP, 0.0_DP ] * Kilometer / Second, &
           P_L  = 1.0d32 * Erg / Centimeter**3, &
           Ye_L = 0.3_DP, &
           D_R  = 1.25d11 * Gram / Centimeter**3, &
           V_R  = [ 0.0_DP, 0.0_DP, 0.0_DP ] * Kilometer / Second, &
           P_R  = 1.0d31 * Erg / Centimeter**3, &
           Ye_R = 0.3_DP, &
           StartTime = StartTime )

  CALL EvolveFields &
         ( t_begin  = StartTime, &
           t_end    = 2.5d-0 * Microsecond, &
           dt_write = 5.0d-2 * Microsecond, &
           UpdateFields = SSP_RK )

  CALL FinalizeProgram

END PROGRAM RiemannProblem1D_NuclearEOS


      subroutine bspp2d ( t, bcoef, n, k, m, scrtch, break, coef, l )
c  from  * a practical guide to splines *  by c. de boor
calls  bsplvb
c  this is an extended version of  bsplpp  for use with tensor products
c
converts the b-representation  t, bcoef(.,j), n, k  of some spline into
c  its pp-representation  break, coef(j,.,.), l, k , j=1, ..., m  .
c
c******  i n p u t  ******
c  t.....knot sequence, of length  n+k
c  bcoef(.,j) b-spline coefficient sequence, of length	n ,j=1,...,m
c  n.....length of  bcoef  and	dimension of spline space  spline(k,t)
c  k.....order of the spline
c
c  w a r n i n g  . . .  the restriction   k .le. kmax (= 20)	is impo-
c	 sed by the arbitrary dimension statement for  biatx  below, but
c	 is  n o w h e r e   c h e c k e d   for.
c
c  m	 number of data sets
c
c******  w o r k   a r e a  ******
c  scrtch   of size  (k,k,m), needed to contain bcoeffs of a piece of
c	 the spline and its  k-1  derivatives	for each of the m sets
c
c******  o u t p u t  ******
c  break.....breakpoint sequence, of length  l+1, contains (in increas-

c	 ing order) the distinct points in the sequence  t(k),...,t(n+1)
c  coef(mm,.,.)  array of size (k,n), with  coef(mm,i,j) = (i-1)st der-
c	 ivative of  mm-th  spline at break(j) from the right, mm=1,.,m
c  l.....number of polynomial pieces which make up the spline in the in-
c	 terval  (t(k), t(n+1))
c
c******  m e t h o d  ******
c     for each breakpoint interval, the  k  relevant b-coeffs of the
c  spline are found and then differenced repeatedly to get the b-coeffs

c  of all the derivatives of the spline on that interval. the spline and
c  its first  k-1  derivatives are then evaluated at the left end point

c  of that interval, using  bsplvb  repeatedly to obtain the values of
c  all b-splines of the appropriate order at that point.
c
c     parameter kmax = 20
      integer k,l,m,n,	 i,j,jp1,kmj,left,lsofar,mm
      real bcoef(n,m),break(1),coef(m,k,1),t(1),   scrtch(k,k,m)
     *					      ,biatx(20),diff,fkmj,sum
c
c    *					      ,biatx(kmax),diff,fkmj,sum
c     dimension break(l+1),coef(k,l),t(n+k)
current fortran standard makes it impossible to specify the length of
c  break , coef  and  t  precisely without the introduction of otherwise
c  superfluous additional arguments.
      lsofar = 0
      break(1) = t(k)
      do 50 left=k,n
c				 find the next nontrivial knot interval.
	 if (t(left+1) .eq. t(left))	go to 50
	 lsofar = lsofar + 1
	 break(lsofar+1) = t(left+1)
	 if (k .gt. 1)			go to 9
	 do 5 mm=1,m
    5	    coef(mm,1,lsofar) = bcoef(left,mm)
					go to 50
c	 store the k b-spline coeff.s relevant to current knot interval

c			      in  scrtch(.,1) .
    9	 do 10 i=1,k
	    do 10 mm=1,m
   10	       scrtch(i,1,mm) = bcoef(left-k+i,mm)
c
c	 for j=1,...,k-1, compute the  k-j  b-spline coeff.s relevant to
c	 current knot interval for the j-th derivative by differencing
c	 those for the (j-1)st derivative, and store in scrtch(.,j+1) .

	 do 20 jp1=2,k
	    j = jp1 - 1
	    kmj = k - j
	    fkmj = float(kmj)
	    do 20 i=1,kmj
	       diff = (t(left+i) - t(left+i - kmj))/fkmj
	       if (diff .le. 0.)	 go to 20
	       do 15 mm=1,m
   15		  scrtch(i,jp1,mm) =
     *		  (scrtch(i+1,j,mm) - scrtch(i,j,mm))/diff
   20	       continue
c
c	 for  j = 0, ..., k-1, find the values at  t(left)  of the  j+1

c	 b-splines of order  j+1  whose support contains the current
c	 knot interval from those of order  j  (in  biatx ), then comb-

c	 ine with the b-spline coeff.s (in scrtch(.,k-j) ) found earlier
c	 to compute the (k-j-1)st derivative at  t(left)  of the given
c	 spline.
c	    note. if the repeated calls to  bsplvb  are thought to gene-
c	 rate too much overhead, then replace the first call by
c	    biatx(1) = 1.
c	 and the subsequent call by the statement
c	    j = jp1 - 1
c	 followed by a direct copy of the lines
c	    deltar(j) = t(left+j) - x
c		   ......
c	    biatx(j+1) = saved
c	 from  bsplvb . deltal(kmax)  and  deltar(kmax)  would have to
c	 appear in a dimension statement, of course.
c
	 call bsplvb ( t, 1, 1, t(left), left, biatx )
	 do 25 mm=1,m
   25	    coef(mm,k,lsofar) = scrtch(1,k,mm)
	 do 30 jp1=2,k
	    call bsplvb ( t, jp1, 2, t(left), left, biatx )
	    kmj = k+1 - jp1
	    do 30 mm=1,m
	       sum = 0.
	       do 28 i=1,jp1
   28		  sum = biatx(i)*scrtch(i,kmj,mm) + sum
   30	       coef(mm,kmj,lsofar) = sum
   50	 continue
      l = lsofar
					return
      end


! { dg-options "-Wundefined-do-loop" }
! Program to check corner cases for DO statements.

program do_1
  implicit none
  integer i, j

  ! limit=HUGE(i), step 1
  j = 0
  do i = HUGE(i) - 10, HUGE(i), 1 ! { dg-warning "is undefined as it overflows" }
    j = j + 1
  end do
  if (j .ne. 11) call abort

  ! limit=-HUGE(i)-1, step -1
  j = 0
  do i = -HUGE(i) + 10 - 1, -HUGE(i) - 1, -1 ! { dg-warning "is undefined as it underflows" }
    j = j + 1
  end do
  if (j .ne. 11) call abort

end program


MODULE mo_laplace_inversion

  ! This module serves numerical laplace-inversion

  ! Written Sebastian Mueller, June 2014

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2014 Sebastian Mueller
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  use mo_kind,          only: i4, i8, SP, DP
  use mo_combinatorics, only: binomcoeffi
  use mo_functions,     only: factorial

  implicit none

  PUBLIC :: NLInvSteh            ! Laplace back-transformed function by Stehfest algorithm

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

  !     NAME
  !         NLInvSteh

  !     PURPOSE
  !         Calculates numerically the laplace-inversion of a given function for given time-values (and optionaly space-values)
  !         that are given in an array
  !     CALLING SEQUENCE
  !         out = NLInvStehvec(func, para, [r,] t, n)

  !     INTENT(IN)
  !>        REAL(sp/dp)                 :: func         function to be inverted (f([r,]s,para))
  !>        REAL(sp/dp), DIMENSION(:)   :: para         Parameters for the given function
  !>       [REAL(sp/dp), DIMENSION(:)   :: r            input radius]
  !>        REAL(sp/dp), DIMENSION(:)   :: t            input time
  !>        integer(i4/i8)              :: n            boundary for the stehfest-algorithm (recommended: 6/8/10/12)

  !     INTENT(INOUT)
  !>        None

  !     INTENT(OUT)
  !>        None

  !     INTENT(IN), OPTIONAL
  !>        None

  !     INTENT(INOUT), OPTIONAL
  !>        None

  !     INTENT(OUT), OPTIONAL
  !>        None

  !     RETURNS
  !>        real(dp)                    :: NLInvSteh

  !     RESTRICTIONS
  !         1) Stehfest-boundary n must be positiv

  !     EXAMPLE
  !         func(s) = 1/(s^2)

  !         NLInvSteh(func,t,12) ~ t

  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written, Sebastian Mueller, June 2014

  INTERFACE NLInvSteh
     MODULE PROCEDURE NLInvSteh_dp, NLInvSteh_sp, NLInvStehspace_dp, NLInvStehspace_sp, &
          NLInvStehvec_dp, NLInvStehvec_sp, NLInvStehvecspace_dp, NLInvStehvecspace_sp
  END INTERFACE NLInvSteh

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

  PRIVATE

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

CONTAINS

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

  ! c_n=csteh(n, m) computed from the Stehfestalg. m=N/2 n=n k=k (the values are all written in an array)
  function csteh_dp(m)

    implicit none

    integer(i4), intent(in)  :: m
    real(dp), dimension(2*m) :: csteh_dp

    ! local variables
    integer(i4)              :: k, n

    !Check if the given boundary is not to big
    if (m>=11_i4)            stop 'The Stehfest-boundary must be less than 22 for double-precision.'

    csteh_dp            =   0.0_dp

    do n=1_i4, 2*m
       do k=FLOOR((real(n,dp)+1.0_dp)/2.0_dp), min(n,m)
          csteh_dp(n)  =   csteh_dp(n) +   real(k,dp)**real(m+1_i4,dp)*real(binomcoeffi(int(2_i4*k,i8),int(k,i8)),dp)/&
               real(factorial(int(m-k,i8))*factorial(int(n-k,i8))*factorial(int(2_i4*k-n,i8)),dp)

!          csteh_dp(n)  =   csteh_dp(n) +   real(k**(m+1_i4)*binomcoeffi(2_i4*k,k),dp)/&
!               real(factorial(m-k)*factorial(n-k)*factorial(2_i4*k-n),dp)

       end do
       csteh_dp(n)     =   (-1.0_dp)**(n+m)*csteh_dp(n)
!write(*,*) "csteh_dp(",n,")= ", csteh_dp(n)
    end do

  end function csteh_dp

  function csteh_sp(m)

    implicit none

    integer(i4), intent(in)  :: m
    real(sp), dimension(2*m) :: csteh_sp

    ! local variables
    integer(i4)              :: k, n

    !Check if the given boundary is not to big
    if (m>=7_i4)            stop 'The Stehfest-boundary must be less than 14 for single-precision.'

    csteh_sp            =   0.0_sp

    do n=1_i4, 2*m
       do k=FLOOR((real(n,sp)+1.0_sp)/2.0_sp), min(n,m)
          csteh_sp(n)  =   csteh_sp(n) +   real(k,sp)**real(m+1_i4,sp)*real(binomcoeffi(int(2_i4*k,i8),int(k,i8)),sp)/&
               real(factorial(int(m-k,i8))*factorial(int(n-k,i8))*factorial(int(2_i4*k-n,i8)),sp)
       end do
       csteh_sp(n)     =   (-1.0_sp)**(n+m)*csteh_sp(n)
!write(*,*) "csteh_sp(",n,")= ", csteh_sp(n)
    end do

  end function csteh_sp

  !Stehfestalg for only-time functions with array-input

  function NLInvStehvec_dp( func, para, t, n)

    !Interface for the given function
    INTERFACE
       function func(s, para)
         use mo_kind, only: dp
         implicit none
         real(dp), dimension(:), intent(in) :: s
         real(dp), dimension(:), intent(in) :: para
         real(dp), dimension(size(s))       :: func
       end function func
    END INTERFACE

    real(dp),    dimension(:), intent(in)   :: para
    real(dp),    dimension(:), intent(in)   :: t
    integer(i4),               intent(in)   :: n

    real(dp),    dimension(size(t))         :: NLInvStehvec_dp

    !intern variables
    integer(i4)                                                     :: m,i
    real(dp),   dimension(size(t))                                  :: a
    real(dp),   dimension(2*Ceiling(real(n,dp)/2.0_dp))             :: csteh
    real(dp),   dimension(size(t), 2*Ceiling(real(n,dp)/2.0_dp))    :: funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'
    !Check if there are time-values
    if (size(t)==0_i4)      stop 'There are no given time-values.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,dp)/2.0_dp)

    !Define the coefficients c_n
    csteh                   =   csteh_dp(m)

    !Evaluate all necessary function points to call the function only one time
    !set all necessary s-values into a matrix
    do i=1_i4, 2*m
       funcpoints(:,i)     =   real(i,dp)/t*log(2.0_dp)
    end do

    !get the function-values for all needed s-values
    funcpoints              =   reshape(func(pack(funcpoints,.true.), para), (/size(t),2*m/))

    !Calculate the Lapalce-inversion
    a                       =   log(2.0_dp)/t

    do i = 1, size(t)
       NLInvStehvec_dp(i)  =   dot_product(csteh, funcpoints(i,:))
    end do

    NLInvStehvec_dp         =   a*NLInvStehvec_dp

  end function NLInvStehvec_dp

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

  function NLInvStehvec_sp( func, para, t, n)

    !Interface for the given function
    INTERFACE
       function func(s, para)
         use mo_kind, only: sp
         implicit none
         real(sp), dimension(:), intent(in) :: s
         real(sp), dimension(:), intent(in) :: para
         real(sp), dimension(size(s))       :: func
       end function func
    END INTERFACE

    real(sp),    dimension(:), intent(in)   :: para
    real(sp),    dimension(:), intent(in)   :: t
    integer(i4),               intent(in)   :: n

    real(sp),    dimension(size(t))         :: NLInvStehvec_sp

    !intern variables
    integer(i4)                                                     :: m,i
    real(sp),   dimension(size(t))                                  :: a
    real(sp),   dimension(2*Ceiling(real(n,sp)/2.0_sp))             :: csteh
    real(sp),   dimension(size(t),2*Ceiling(real(n,sp)/2.0_sp))     :: funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'

    !Check if there are time-values
    if (size(t)==0_i4)      stop 'There are no given time-values.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,sp)/2.0_sp)

    !Define the coefficients c_n
    csteh                   =   csteh_sp(m)

    !Evaluate all necessary function points to call the function only one time
    !set all necessary s-values into a matrix
    do i=1_i4, 2*m
       funcpoints(:,i)     =   real(i,sp)/t*log(2.0_sp)
    end do

    !get the function-values for all needed s-values
    funcpoints              =   reshape(func(pack(funcpoints,.true.), para), (/size(t),2*m/))

    !Calculate the Lapalce-inversion
    a                       =   log(2.0_sp)/t

    do i = 1, size(t)
       NLInvStehvec_sp(i)  =   dot_product(csteh, funcpoints(i,:))
    end do

    NLInvStehvec_sp         =   a*NLInvStehvec_sp

  end function NLInvStehvec_sp

  !------------------------------------------------------------------
  !Stehfestalg for space and time functions with array-input

  function NLInvStehvecspace_dp( func, para, r, t, n)

    !Interface for the given function with additional radial-values r
    INTERFACE
       function func(r, s, para)
         use mo_kind, only: dp
         implicit none
         real(dp), dimension(:), intent(in)     :: r
         real(dp), dimension(:), intent(in)     :: s
         real(dp), dimension(:), intent(in)     :: para
         real(dp), dimension(size(r),size(s))   :: func
       end function func
    END INTERFACE

    real(dp),    dimension(:), intent(in)       :: para
    real(dp),    dimension(:), intent(in)       :: r
    real(dp),    dimension(:), intent(in)       :: t
    integer(i4),               intent(in)       :: n

    real(dp),    dimension(size(r),size(t))     :: NLInvStehvecspace_dp

    !intern variables
    integer(i4)                                                             :: m,i,j
    real(dp),   dimension(size(t))                                          :: a
    real(dp),   dimension(2*Ceiling(real(n,dp)/2.0_dp))                     :: csteh
    real(dp),   dimension(size(t), 2*Ceiling(real(n,dp)/2.0_dp))            :: timepoints
    real(dp),   dimension(size(r), size(t), 2*Ceiling(real(n,dp)/2.0_dp))   :: funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'
    !Check if there are time-values and if they are valid
    if (size(t)==0_i4)      stop 'There are no given time-values.'
    !Check if there are space-values and if they are valid
    if (size(r)==0_i4)      stop 'There are no given space-values.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,dp)/2.0_dp)

    !Define the coefficients c_n
    csteh                   =   csteh_dp(m)

    !Evaluate all necessary function points to call the function only one time
    !set all necessary s-values into a matrix
    do i=1_i4, 2*m
       timepoints(:,i)     =   real(i,dp)/t*log(2.0_dp)
    end do

    !get the function-values for all needed s-values
    funcpoints              =   reshape(func(r,pack(timepoints,.true.), para), (/size(r),size(t),2*m/))

    !Calculate the Lapalce-inversion
    a                       =   log(2.0_dp)/t

    do i = 1, size(r)
       do j = 1, size(t)
          NLInvStehvecspace_dp(i,j)   =   dot_product(csteh, funcpoints(i,j,:))
       end do
       NLInvStehvecspace_dp(i,:)       =   a*NLInvStehvecspace_dp(i,:)
    end do

  end function NLInvStehvecspace_dp

  function NLInvStehvecspace_sp( func, para, r, t, n)

    !Interface for the given function with additional radial-values r
    INTERFACE
       function func(r, s, para)
         use mo_kind, only: sp
         implicit none
         real(sp), dimension(:), intent(in)     :: r
         real(sp), dimension(:), intent(in)     :: s
         real(sp), dimension(:), intent(in)     :: para
         real(sp), dimension(size(r),size(s))   :: func
       end function func
    END INTERFACE

    real(sp),    dimension(:), intent(in)       :: para
    real(sp),    dimension(:), intent(in)       :: r
    real(sp),    dimension(:), intent(in)       :: t
    integer(i4),               intent(in)       :: n

    real(sp),    dimension(size(r),size(t))     :: NLInvStehvecspace_sp

    !intern variables
    integer(i4)                                                             :: m,i,j
    real(sp),   dimension(size(t))                                          :: a
    real(sp),   dimension(2*Ceiling(real(n,sp)/2.0_sp))                     :: csteh
    real(sp),   dimension(size(t), 2*Ceiling(real(n,sp)/2.0_sp))            :: timepoints
    real(sp),   dimension(size(r), size(t), 2*Ceiling(real(n,sp)/2.0_sp))   :: funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'
    !Check if there are time-values and if they are valid
    if (size(t)==0_i4)      stop 'There are no given time-values.'
    !Check if there are space-values and if they are valid
    if (size(r)==0_i4)      stop 'There are no given space-values.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,sp)/2.0_sp)

    !Define the coefficients c_n
    csteh                   =   csteh_sp(m)

    !Evaluate all necessary time points to call the function only ONE time
    !set all necessary s-values into a matrix
    do i=1_i4, 2*m
       timepoints(:,i)     =   real(i,sp)/t*log(2.0_sp)
    end do

    !get the function-values for all needed s-values
    funcpoints              =   reshape(func(r,pack(timepoints,.true.), para), (/size(r),size(t),2*m/))

    !Calculate the Lapalce-inversion
    a                       =   log(2.0_sp)/t

    do i = 1, size(r)
       do j = 1, size(t)
          NLInvStehvecspace_sp(i,j)   =   dot_product(csteh, funcpoints(i,j,:))
       end do
       NLInvStehvecspace_sp(i,:)       =   a*NLInvStehvecspace_sp(i,:)
    end do

  end function NLInvStehvecspace_sp

  !stehfest for single input value

  function NLInvSteh_dp( func, para, t, n)

    !Interface for the given function
    INTERFACE
       function func(s, para)
         use mo_kind, only: dp
         implicit none
         real(dp),               intent(in) :: s
         real(dp), dimension(:), intent(in) :: para
         real(dp)                           :: func
       end function func
    END INTERFACE

    real(dp),    dimension(:), intent(in)   :: para
    real(dp),                  intent(in)   :: t
    integer(i4),               intent(in)   :: n
    real(dp)                                :: NLInvSteh_dp

    !intern variables
    integer(i4)                                         :: m,i
    real(dp),   dimension(2*Ceiling(real(n,dp)/2.0_dp)) :: csteh, funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,dp)/2.0_dp)

    !Define the coefficients c_n
    csteh                   =   csteh_dp(m)

    !Evaluate all necessary function points
    !get the function-values for all needed s-values
    do i=1_i4, 2*m
       funcpoints(i)       =   func(real(i,dp)/t*log(2.0_dp), para)
    end do

    !Calculate the Lapalce-inversion
    NLInvSteh_dp            =   (log(2.0_dp)/t)*dot_product(csteh, funcpoints)

  end function NLInvSteh_dp

  !------------------------------------------------------------------
  !Stehfestalg for only-time functions with single-input

  function NLInvSteh_sp( func, para, t, n)

    !Interface for the given function
    INTERFACE
       function func(s, para)
         use mo_kind, only: sp
         implicit none
         real(sp),               intent(in) :: s
         real(sp), dimension(:), intent(in) :: para
         real(sp)                           :: func
       end function func
    END INTERFACE

    real(sp),    dimension(:), intent(in)   :: para
    real(sp),                  intent(in)   :: t
    integer(i4),               intent(in)   :: n
    real(sp)                                :: NLInvSteh_sp

    !intern variables
    integer(i4)                                         :: m,i
    real(sp),   dimension(2*Ceiling(real(n,sp)/2.0_sp)) :: csteh, funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,sp)/2.0_sp)

    !Define the coefficients c_n
    csteh                   =   csteh_sp(m)

    !Evaluate all necessary function points
    !get the function-values for all needed s-values
    do i=1_i4, 2*m
       funcpoints(i)       =   func(real(i,sp)/t*log(2.0_sp), para)
    end do

    !Calculate the Lapalce-inversion
    NLInvSteh_sp        =   (log(2.0_sp)/t)*dot_product(csteh, funcpoints)

  end function NLInvSteh_sp

  !------------------------------------------------------------------
  !Stehfestalg for space and time functions with single-input

  function NLInvStehspace_dp( func, para, r, t, n)

    !Interface for the given function with additional radial-values r
    INTERFACE
       function func(r, s, para)
         use mo_kind, only: dp
         implicit none
         real(dp),               intent(in)     :: r
         real(dp),               intent(in)     :: s
         real(dp), dimension(:), intent(in)     :: para
         real(dp)                               :: func
       end function func
    END INTERFACE

    real(dp),    dimension(:), intent(in)       :: para
    real(dp),                  intent(in)       :: r,t
    integer(i4),               intent(in)       :: n

    real(dp)                                    :: NLInvStehspace_dp

    !intern variables
    integer(i4)                                         :: m,i
    real(dp),   dimension(2*Ceiling(real(n,dp)/2.0_dp)) :: csteh, funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,dp)/2.0_dp)

    !Define the coefficients c_n
    csteh                   =   csteh_dp(m)

    !get the function-values for all needed s-values
    do i=1_i4, 2*m
       funcpoints(i)       =   func(r, real(i,dp)/t*log(2.0_dp), para)
    end do

    !Calculate the Lapalce-inversion
    NLInvStehspace_dp       =   (log(2.0_dp)/t)*dot_product(csteh, funcpoints)

  end function NLInvStehspace_dp

  function NLInvStehspace_sp( func, para, r, t, n)

    !Interface for the given function with additional radial-values r
    INTERFACE
       function func(r, s, para)
         use mo_kind, only: sp
         implicit none
         real(sp),               intent(in)     :: r
         real(sp),               intent(in)     :: s
         real(sp), dimension(:), intent(in)     :: para
         real(sp)                               :: func
       end function func
    END INTERFACE

    real(sp),    dimension(:), intent(in)       :: para
    real(sp),                  intent(in)       :: r,t
    integer(i4),               intent(in)       :: n

    real(sp)                                    :: NLInvStehspace_sp

    !intern variables
    integer(i4)                                         :: m,i
    real(sp),   dimension(2*Ceiling(real(n,sp)/2.0_sp)) :: csteh, funcpoints

    !Check if the given boundary is a positiv number
    if (n<=0_i4)            stop 'The Stehfest-boundary n must be positiv.'

    !If n is odd take the next bigger even number N=2m
    m                       =   Ceiling(real(n,sp)/2.0_sp)

    !Define the coefficients c_n
    csteh                   =   csteh_sp(m)

    !get the function-values for all needed s-values
    do i=1_i4, 2*m
       funcpoints(i)       =   func(r, real(i,sp)/t*log(2.0_sp), para)
    end do

    !Calculate the Lapalce-inversion
    NLInvStehspace_sp       =   (log(2.0_sp)/t)*dot_product(csteh, funcpoints)

  end function NLInvStehspace_sp

end module mo_laplace_inversion


MODULE my_sub
IMPLICIT NONE
CONTAINS
  SUBROUTINE running_sum(sum, value)
  IMPLICIT NONE
  !REAL, POINTER :: sum, value
  REAL :: sum, value
  !ALLOCATE(sum)
  sum = sum + value
  END SUBROUTINE running_sum
END MODULE my_sub

PROGRAM sum_values
USE my_sub
IMPLICIT NONE
INTEGER :: istat
!REAL, POINTER :: sum, value
REAL :: sum, value
!ALLOCATE(sum, value, STAT=istat)
WRITE(*, *) 'Enter values to add: '
DO
  READ(*, *, IOSTAT=istat) value
  IF (istat /= 0) EXIT
  CALL running_sum(sum, value)
  WRITE(*, *) ' The sum is ', sum
END DO
END PROGRAM sum_values


!> Reference: https://refactoring.guru/design-patterns/visitor/go/example
program test_visitor

    use visitor_pattern, only: square, circle, rectangle, area_calculator, middle_coordinates

    type(square) :: s = square(side=2)
    type(circle) :: c = circle(radius=3)
    type(rectangle) :: r = rectangle(l=2, b=3)

    type(area_calculator) :: a
    type(middle_coordinates) :: m

    !> area_calculator visiting shapes
    call s%accept(a)
    call c%accept(a)
    call r%accept(a)

    !> middle_coordinates visiting shapes
    call s%accept(m)
    call c%accept(m)
    call r%accept(m)

    !> Getting type of shape
    print *, s%get_type()
    print *, c%get_type()
    print *, r%get_type()

end program test_visitor

!> Results shall be:

!  Calculating area for square.🔥
!  Calculating area for circle.🔥
!  Calculating area for rectangle.🔥
!  Calculating middle point coordinates for square.💠
!  Calculating middle point coordinates for circle.💠
!  Calculating middle point coordinates for rectangle.💠
!  Square
!  Circle
!  Rectangle


	SUBROUTINE RS_VVDE  ( temp, nout, iret )
C************************************************************************
C* RS_VVDE								*
C*									*
C* This subroutine converts the VV code to visibility in tens of meters	*
C*									*
C* RS_VVDE  ( TEMP, NOUT, IRET )					*
C*									*
C* Input parameters:							*
C*	TEMP		INTEGER		VV code				*
C*									*
C* Output parameters:							*
C*	NOUT		INTEGER		Decoded visibility		*
C*	IRET		INTEGER		Return code			*
C*					  0 = Normal completion		*
C*					 -1 = Unexpected code		*
C**									*
C* Log:									*
C* J. Nielsen/MIT	10/86						*
C* J. Nielsen/TAMU	 2/92	Gempacized				*
C************************************************************************
	INTEGER		temp
C
	INTEGER		nout, iret
C------------------------------------------------------------------------
	iret = 0
	IF  ( ( temp .lt. 0 ) .or. ( temp .ge. 100 ) )  THEN
	    iret = -1
	    RETURN
	ENDIF
	IF  ( temp .le. 55 )  THEN
C
C*	    Visibility less than 5 km
C
	    nout = temp * 10
	ELSE IF  ( temp .le. 80 )  THEN
C
C*	    Visibility up to 30 km
C
	    nout = ( temp - 50 ) * 100
	ELSE IF  ( temp .lt. 90 )  THEN
C
C*	    Visibility up to 70 km; encode >70 as if 70
C
	    nout = ( temp - 74 ) * 500
	ELSE
C
C*	    Less exact visibility codes
C
	    IF  ( temp .eq. 90 )  nout = 0
	    IF  ( temp .eq. 91 )  nout = 5
	    IF  ( temp .eq. 92 )  nout = 20
	    IF  ( temp .eq. 93 )  nout = 50
	    IF  ( temp .eq. 94 )  nout = 100
	    IF  ( temp .eq. 95 )  nout = 200
	    IF  ( temp .eq. 96 )  nout = 400
	    IF  ( temp .eq. 97 )  nout = 1000
	    IF  ( temp .eq. 98 )  nout = 2000
	    IF  ( temp .eq. 99 )  nout = 5000
	END IF
	RETURN
	END


*DECK DBNDSL
      SUBROUTINE DBNDSL (MODE, G, MDG, NB, IP, IR, X, N, RNORM)
C***BEGIN PROLOGUE  DBNDSL
C***PURPOSE  Solve the least squares problem for a banded matrix using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      DOUBLE PRECISION (BNDSOL-S, DBNDSL-D)
C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     These subroutines solve the least squares problem Ax = b for
C     banded matrices A using sequential accumulation of rows of the
C     data matrix.  Exactly one right-hand side vector is permitted.
C
C     These subroutines are intended for the type of least squares
C     systems that arise in applications such as curve or surface
C     fitting of data.  The least squares equations are accumulated and
C     processed using only part of the data.  This requires a certain
C     user interaction during the solution of Ax = b.
C
C     Specifically, suppose the data matrix (A B) is row partitioned
C     into Q submatrices.  Let (E F) be the T-th one of these
C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
C     and the dimension of C is MT by NB.  The value of NB is the
C     bandwidth of A.  The dimensions of the leading block of zeros in E
C     are MT by JT-1.
C
C     The user of the subroutine DBNDAC provides MT,JT,C and F for
C     T=1,...,Q.  Not all of this data must be supplied at once.
C
C     Following the processing of the various blocks (E F), the matrix
C     (A B) has been transformed to the form (R D) where R is upper
C     triangular and banded with bandwidth NB.  The least squares
C     system Rx = d is then easily solved using back substitution by
C     executing the statement CALL DBNDSL(1,...). The sequence of
C     values for JT must be nondecreasing.  This may require some
C     preliminary interchanges of rows and columns of the matrix A.
C
C     The primary reason for these subroutines is that the total
C     processing can take place in a working array of dimension MU by
C     NB+1.  An acceptable value for MU is
C
C                       MU = MAX(MT + N + 1),
C
C     where N is the number of unknowns.
C
C     Here the maximum is taken over all values of MT for T=1,...,Q.
C     Notice that MT can be taken to be a small as one, showing that
C     MU can be as small as N+2.  The subprogram DBNDAC processes the
C     rows more efficiently if MU is large enough so that each new
C     block (C F) has a distinct value of JT.
C
C     The four principle parts of these algorithms are obtained by the
C     following call statements
C
C     CALL DBNDAC(...)  Introduce new blocks of data.
C
C     CALL DBNDSL(1,...)Compute solution vector and length of
C                       residual vector.
C
C     CALL DBNDSL(2,...)Given any row vector H solve YR = H for the
C                       row vector Y.
C
C     CALL DBNDSL(3,...)Given any column vector W solve RZ = W for
C                       the column vector Z.
C
C     The dots in the above call statements indicate additional
C     arguments that will be specified in the following paragraphs.
C
C     The user must dimension the array appearing in the call list..
C     G(MDG,NB+1)
C
C     Description of calling sequence for DBNDAC..
C
C     The entire set of parameters for DBNDAC are
C
C     Input.. All Type REAL variables are DOUBLE PRECISION
C
C     G(*,*)            The working array into which the user will
C                       place the MT by NB+1 block (C F) in rows IR
C                       through IR+MT-1, columns 1 through NB+1.
C                       See descriptions of IR and MT below.
C
C     MDG               The number of rows in the working array
C                       G(*,*).  The value of MDG should be .GE. MU.
C                       The value of MU is defined in the abstract
C                       of these subprograms.
C
C     NB                The bandwidth of the data matrix A.
C
C     IP                Set by the user to the value 1 before the
C                       first call to DBNDAC.  Its subsequent value
C                       is controlled by DBNDAC to set up for the
C                       next call to DBNDAC.
C
C     IR                Index of the row of G(*,*) where the user is
C                       the user to the value 1 before the first call
C                       to DBNDAC.  Its subsequent value is controlled
C                       by DBNDAC. A value of IR .GT. MDG is considered
C                       an error.
C
C     MT,JT             Set by the user to indicate respectively the
C                       number of new rows of data in the block and
C                       the index of the first nonzero column in that
C                       set of rows (E F) = (0 C 0 F) being processed.
C     Output.. All Type REAL variables are DOUBLE PRECISION
C
C     G(*,*)            The working array which will contain the
C                       processed rows of that part of the data
C                       matrix which has been passed to DBNDAC.
C
C     IP,IR             The values of these arguments are advanced by
C                       DBNDAC to be ready for storing and processing
C                       a new block of data in G(*,*).
C
C     Description of calling sequence for DBNDSL..
C
C     The user must dimension the arrays appearing in the call list..
C
C     G(MDG,NB+1), X(N)
C
C     The entire set of parameters for DBNDSL are
C
C     Input..
C
C     MODE              Set by the user to one of the values 1, 2, or
C                       3.  These values respectively indicate that
C                       the solution of AX = B, YR = H or RZ = W is
C                       required.
C
C     G(*,*),MDG,       These arguments all have the same meaning and
C      NB,IP,IR         contents as following the last call to DBNDAC.
C
C     X(*)              With mode=2 or 3 this array contains,
C                       respectively, the right-side vectors H or W of
C                       the systems YR = H or RZ = W.
C
C     N                 The number of variables in the solution
C                       vector.  If any of the N diagonal terms are
C                       zero the subroutine DBNDSL prints an
C                       appropriate message.  This condition is
C                       considered an error.
C
C     Output..
C
C     X(*)              This array contains the solution vectors X,
C                       Y or Z of the systems AX = B, YR = H or
C                       RZ = W depending on the value of MODE=1,
C                       2 or 3.
C
C     RNORM             If MODE=1 RNORM is the Euclidean length of the
C                       residual vector AX-B.  When MODE=2 or 3 RNORM
C                       is set to zero.
C
C     Remarks..
C
C     To obtain the upper triangular matrix and transformed right-hand
C     side vector D so that the super diagonals of R form the columns
C     of G(*,*), execute the following Fortran statements.
C
C     NBP1=NB+1
C
C     DO 10 J=1, NBP1
C
C  10 G(IR,J) = 0.E0
C
C     MT=1
C
C     JT=N+1
C
C     CALL DBNDAC(G,MDG,NB,IP,IR,MT,JT)
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBNDSL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION G(MDG,*),X(*)
C***FIRST EXECUTABLE STATEMENT  DBNDSL
      ZERO=0.D0
C
      RNORM=ZERO
      GO TO (10,90,50), MODE
C                                   ********************* MODE = 1
C                                   ALG. STEP 26
   10      DO 20 J=1,N
           X(J)=G(J,NB+1)
   20 CONTINUE
      RSQ=ZERO
      NP1=N+1
      IRM1=IR-1
      IF (NP1.GT.IRM1) GO TO 40
           DO 30 J=NP1,IRM1
           RSQ=RSQ+G(J,NB+1)**2
   30 CONTINUE
      RNORM=SQRT(RSQ)
   40 CONTINUE
C                                   ********************* MODE = 3
C                                   ALG. STEP 27
   50      DO 80 II=1,N
           I=N+1-II
C                                   ALG. STEP 28
           S=ZERO
           L=MAX(0,I-IP)
C                                   ALG. STEP 29
           IF (I.EQ.N) GO TO 70
C                                   ALG. STEP 30
           IE=MIN(N+1-I,NB)
                DO 60 J=2,IE
                JG=J+L
                IX=I-1+J
                S=S+G(I,JG)*X(IX)
   60 CONTINUE
C                                   ALG. STEP 31
   70      IF (G(I,L+1)) 80,130,80
   80      X(I)=(X(I)-S)/G(I,L+1)
C                                   ALG. STEP 32
      RETURN
C                                   ********************* MODE = 2
   90      DO 120 J=1,N
           S=ZERO
           IF (J.EQ.1) GO TO 110
           I1=MAX(1,J-NB+1)
           I2=J-1
                DO 100 I=I1,I2
                L=J-I+1+MAX(0,I-IP)
                S=S+X(I)*G(I,L)
  100 CONTINUE
  110      L=MAX(0,J-IP)
           IF (G(J,L+1)) 120,130,120
  120      X(J)=(X(J)-S)/G(J,L+1)
      RETURN
C
  130 CONTINUE
      NERR=1
      IOPT=2
      CALL XERMSG ('SLATEC', 'DBNDSL',
     +   'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' //
     +   'MATRIX.', NERR, IOPT)
      RETURN
      END