!----------------------------------------------------------------------------------------------------------------------------------!
SUBROUTINE bicgstabl(l,n,x,nonzero_x,b,matvec,l_precond,pcnd,toler,mxmatvec,info)
!----------------------------------------------------------------------------------------------------------------------------------!

!===purpose===! 

!**********************************************************************************************************************************!
!**************************** bicgstabl: (Preconditioned Real) Bi-Conjugate Gradient Stabilized solver ****************************!
!****************************  Iterative method for solving real non-symmetric linear system: A*x=b *******************************!
!**********************************************************************************************************************************!

!*** Developer: Sylvain Nintcheu Fata
!*** Version:   V.1.3
!*** Released:  Jun 14, 2012


!******************************************************!
! Parameter list:
!******************************************************!
!
! l         == (input) INTEGER BiCGstab's dimension
! n         == (input) INTEGER size of the system to solve 
! x         == (input/output) DOUBLE PRECISION array dimension n, initial guess on input, solution on output
! nonzero_x == (input) LOGICAL, indicates whether the initial guess is zero vector
!              If nonzero_x == .false., one matrix-vector multiplication will be saved
! b         == (input) DOUBLE PRECISION array dimension n, right-hand side (rhs) vector
! matvec    == (input) EXTERNAL name of matrix-vector subroutine to deliver y:=A*x by CALL matvec(n,x,y)
! l_precond == (input) EXTERNAL name of subroutine to perform a left preconditioner by CALL l_precond(n,x)
!              This call delivers solution to M*y=x, M is the left preconditioning matrix
!              x is rhs on input, and solution y is written in x on output
! pcnd      == (input) LOGICAL, indicates whether the preconditioner exist
!              If pcnd == .true., there is a preconditioner otherwise pcnd is .false.
! toler     == (input) DOUBLE PRECISION tolerance for the relative residual norm stopping criterion: ||r_k|| <= toler*||r_0||
! mxmatvec  == (input/output) INTEGER.  On input: maximum number of matrix-vector multiplications allowed
!                                      On output: actual number of matrix-vector multiplications achieved
! work      == (workspace) DOUBLE PRECISION array dimension (n,3+2*(l+1))
! rwork     == (workspace) DOUBLE PRECISION array dimension (l+1,3+2*(l+1))
! iwork     == (workspace) INTEGER array dimension (l+1)
! info      == (output) INTEGER.  Info = 0 in case of normal computations
!              info = m < 0 - means paramater number m has an illegal value
!              info = 1 - means no convergence achieved (stopping criterion is not fulfilled)
!              info = 2 - means breakdown of the algorithm (try to enlarge parameter l to get rid of this)


!******************************************************!
! Original Fortran 77 routine name and parameters:
!******************************************************!
!
!      subroutine bistbl (l, n, x, b, mv, solve, tol, mxmv, work, ldw, rwork, ldrw, iwork, info)
!
! subroutine bistbl v1.0 1995 by D.R. Fokkema.
!
! Parameter list (by M.Botchev, October, 1997):
!
! l      == (input) INTEGER BiCGstab's dimension
! n      == (input) INTEGER size of the system to solve 
! x      == (input/output) DOUBLE PRECISION array dimension n
!           initial guess on input, solution on output
! b      == (input) DOUBLE PRECISION array dimension n
!           right-hand side (rhs) vector
! mv     == (input) EXTERNAL name of matrix vector subroutine
!           to deliver y:=A*x by CALL matvec(n,x,y)
! solve  == (input) EXTERNAL name of subroutine to perform
!           a left preconditioner solve by CALL solve(n,x). This call 
!           delivers solution to M*x=x, M is the left preconditioning 
!           matrix, x is rhs on input and solution on output.
! tol    == (input) DOUBLE PRECISION tolerance for the relative
!           residual norm stopping criterion: ||r_k|| <= toler*||r_0||
! mxmv   == (input/output) INTEGER.  On input: maximum number of matrix 
!           vector multiplications allowed to be done.  On input: 
!           actual number of matrix vector multiplications done
! work   == (workspace) DOUBLE PRECISION array dimension (n,3+2*(l+1))
! ldw    == (input) INTEGER leading dimension of work (??)
! rwork  == (workspace) DOUBLE PRECISION array dimension (l+1,3+2*(l+1))
! ldrw   == (input) INTEGER leading dimension of rwork (??)
! iwork  == (workspace) INTEGER array dimension (l+1)
! info   == (output) INTEGER.  Info = 0 in case of normal computations
!           and 
!           info = m < 0 - means paramater number m has an illegal value
!           info = 1 - means no convergence achieved (stopping criterion
!           is not fulfilled)
!           info = 2 - means breakdown of the algorithm (try to enlarge
!           parameter l to get rid of this)


USE KINDS

IMPLICIT NONE

! Parameters:
logical,          intent( in  ) :: nonzero_x,pcnd
integer(kind=k9), intent( in  ) :: l,n
integer(kind=k9), intent(inout) :: mxmatvec
integer(kind=k9), intent( out ) :: info
real   (kind=dp), intent(inout) :: x(n)
real   (kind=dp), intent( in  ) :: b(n)
real   (kind=dp), intent(inout) :: toler

!----------------------------------------------------------------------------------------------------------------------------------!
INTERFACE
!----------------------------------------------------------------------------------------------------------------------------------!

!----------------------------------------------------------------------------------------------------------------------------------!
  SUBROUTINE matvec(m,x,y)
!----------------------------------------------------------------------------------------------------------------------------------!

!===purpose===! 

!**********************************************************************************************************************************!
!******************************************** Compute the Matrix vector product: y=A*x ********************************************!
!**********************************************************************************************************************************!

   USE KINDS

   IMPLICIT NONE
   
    integer(kind=k9), intent(in ) :: m    ! m == Dimension of vectors "x" and "y"
    real   (kind=dp), intent(in ) :: x(m)
    real   (kind=dp), intent(out) :: y(m) ! y = A*x

!----------------------------------------------------------------------------------------------------------------------------------!    
  END SUBROUTINE matvec
!----------------------------------------------------------------------------------------------------------------------------------!  


!----------------------------------------------------------------------------------------------------------------------------------!
  SUBROUTINE l_precond(m,x)
!----------------------------------------------------------------------------------------------------------------------------------!

!===purpose===! 

!**********************************************************************************************************************************!
!************************************************** Apply a left preconditioner ***************************************************!
!************************************************** i.e. solve the system: M*y=x **************************************************!
!**********************************************************************************************************************************!

! Note: M is a left preconditioner
! Note: The solution y is written in x on output

   USE KINDS

   IMPLICIT NONE
   
    integer(kind=k9), intent(in ) :: m ! m == Dimension of the vector "x"
    real   (kind=dp), intent(inout) :: x(m)

!----------------------------------------------------------------------------------------------------------------------------------!    
  END SUBROUTINE l_precond
!----------------------------------------------------------------------------------------------------------------------------------!  


!----------------------------------------------------------------------------------------------------------------------------------!
END INTERFACE
!----------------------------------------------------------------------------------------------------------------------------------!

! Local variables:
logical          :: rcmp, xpdt
integer(kind=k9) :: i, j, k, nmatvec,wsz,lp1,lm1,alloc_st
integer(kind=k9), pointer :: iwork(:) ! iwork(l+1)
real   (kind=dp) :: rnrm0, rnrm
real   (kind=dp) :: mxnrmx, mxnrmr
real   (kind=dp) :: kappa0, kappal
real   (kind=dp), pointer :: work(:,:), rwork(:,:) ! work(n,3+2*(l+1)), rwork(l+1,3+2*(l+1))
real   (kind=dp) :: alpha, beta, omega, rho0, rho1, sigma
real   (kind=dp) :: varrho, hatgamma

! Aliases for the parts of the work array:
integer(kind=k9) :: r, u, xp, bp, zz, y0, yl, y

! Constants:
real(kind=dp),    parameter :: zero = 0.0_dp, one = 1.0_dp, delta = 1.0E-2_dp


!---------------------------------------!
!     .. BLAS and LAPACK ..
!---------------------------------------!
!     subroutine daxpy
!     subroutine dcopy
!     subroutine dgemv
!     subroutine dgetrf
!     subroutine dgetrs
!     subroutine dlacpy
!     subroutine dlaset
!     subroutine dsymv
!     function ddot
!     function dnrm2
!
real(kind=dp),    external :: dnrm2, ddot
!
!     .. Intrinsic ..
!
!      intrinsic dabs, max, sign, dsqrt


!     ===========================
!     .. Executable Statements ..
!     ===========================

      info = 0; lp1 = l+1;
      wsz = 3+2*lp1; 

      if (l < 1) info = -1
      if (n < 1) info = -2
      if (toler <= zero) info = -7
      if (mxmatvec < 0) info = -8

      r = 2; u = 2+lp1 ! r = 2; u = r+lp1
      xp = u+lp1
      bp = xp+1

      zz = 1+lp1
      y0 = zz+lp1
      yl = y0+1
      y = yl+1

      if (info /= 0) return


!     --- Initialize first residual
    lm1 = l-1
    allocate(work(n,wsz),STAT=alloc_st) 
    if ( alloc_st /= 0 ) then  ! If work is not successfully allocated
       write(*,*)'bicgstabl: Allocate array "work" failed with Status=',alloc_st
       stop
    endif
    allocate(rwork(lp1,wsz),STAT=alloc_st) 
    if ( alloc_st /= 0 ) then  ! If rwork is not successfully allocated
       write(*,*)'bicgstabl: Allocate array "rwork" failed with Status=',alloc_st
       stop
    endif
    allocate(iwork(lp1),STAT=alloc_st) 
    if ( alloc_st /= 0 ) then  ! If iwork is not successfully allocated
       write(*,*)'bicgstabl: Allocate array "iwork" failed with Status=',alloc_st
       stop
    endif

    if (nonzero_x) then
      call matvec(n, x, work(1:n,r))
      do i=1,n
         work(i,r) = b(i) - work(i,r) ! work(:,r) = b - work(:,r)
      end do
      nmatvec = 1
    else
      do i=1,n
         work(i,r) = b(i) ! work(:,r) = b
      end do
      nmatvec = 0
    end if

    if (pcnd) then
     call l_precond(n, work(1:n,r))
    endif 


!     --- Initialize iteration loop
      call dcopy(n, work(1,r), 1, work(1,1), 1) ! work(:,1) = work(:,r)
      call dcopy(n, work(1,r), 1, work(1,bp), 1) ! work(:,bp) = work(:,r)
      call dcopy(n, x, 1, work(1,xp), 1)  ! work(:,xp) = x
      call dlaset('n', n, 1, zero, zero, x, 1) ! x = 0.0
      rnrm0 = dnrm2(n, work(1,r), 1) ! rnrm0 = sqrt(dot_product(work(:,r),work(:,r)))
      rnrm = rnrm0

      mxnrmx = rnrm0; mxnrmr = rnrm0
      rcmp = .false.; xpdt = .false.
      alpha = zero; omega = one; sigma = one; rho0 = one


!     --- Iterate
      do while (rnrm>toler*rnrm0 .and. nmatvec<mxmatvec)

!     =====================
!     --- The BiCG part ---
!     =====================

	 rho0 = -omega*rho0
	 do k=1,l
	    rho1 = ddot(n, work(1,1), 1, work(1,r+k-1), 1) ! rho1 = dot_product(work(1:n,1), work(1:n,r+k-1))
	    if (rho0 == zero) then
	       info = 2
	       return
	    endif
	    beta = alpha*(rho1/rho0)
	    rho0 = rho1
	    do j=0,k-1
	       do i=1,n
		  work(i,u+j) = work(i,r+j) - beta*work(i,u+j)
	       enddo
	    enddo
	    call matvec(n, work(1:n,u+k-1), work(1:n,u+k))
	    if (pcnd) call l_precond(n, work(1:n,u+k))
	    nmatvec = nmatvec+1

	    sigma = ddot(n, work(1,1), 1, work(1,u+k), 1) ! sigma = dot_product(work(1:n,1), work(1:n,u+k))
	    if (sigma == zero) then
	       info = 2
	       return
	    endif
	    alpha = rho1/sigma
	    call daxpy(n, alpha, work(1,u), 1, x, 1) ! x = alpha*work(1:n,u) + x
	    do j=0,k-1
	       call daxpy(n,(-alpha),work(1,u+j+1),1,work(1,r+j),1) ! work(1:n,r+j) = -alpha*work(1:n,u+j+1) + work(1:n,r+j)
	    enddo
	    call matvec(n, work(1:n,r+k-1), work(1:n,r+k))
	    if (pcnd) call l_precond(n, work(1:n,r+k))
	    nmatvec = nmatvec+1

	    rnrm = dnrm2(n, work(1,r), 1) ! rnrm = sqrt(dot_product(work(1:n,r),work(1:n,r)))
	    mxnrmx = max(mxnrmx, rnrm); mxnrmr = max(mxnrmr, rnrm)
	 enddo


!     ==================================
!     --- The convex polynomial part ---
!     ==================================

!        --- Z = R'R

	 do i=1,lp1
	    call dgemv('t',n,lp1-(i-1),one,work(1,r+i-1),n,work(1,r+i-1),1,zero,rwork(i,i),1) ! The lower triangular part of Z is computed
	    ! rwork(i:l+1,i) = matmul(transpose(work(1:n,r+i-1:r+l)),work(1:n,r+i-1))
	    
	    call dcopy(l-(i-1),rwork(i+1,i),1,rwork(i,1+i),lp1) ! Compute the strictly upper triangular part of Z knowing that Z^T=Z
	    ! rwork(i,1+i:l+1) = rwork(i+1:l+1,i)
	 enddo

	 call dlacpy('n',lp1,lp1,rwork(1,1),lp1,rwork(1,zz),lp1) ! rwork(1:l+1,zz:zz+l) = rwork(1:l+1,1:l+1) <==> duplicate
	 call dgetrf(lm1,lm1,rwork(2,zz+1),lp1,iwork,info) ! LU factorization


!        --- tilde r0 and tilde rl (small vectors)
	 rwork(1,y0) = -one
	 call dcopy(lm1,rwork(2,1),1,rwork(2,y0),1) ! rwork(2:l,y0) = rwork(2:l,1)
	 call dgetrs('n',lm1,1,rwork(2,zz+1),lp1,iwork,rwork(2,y0),lp1,info)
	 rwork(lp1,y0) = zero

	 rwork(1,yl) = zero
	 call dcopy(lm1,rwork(2,lp1),1,rwork(2,yl),1) ! rwork(2:l,yl) = rwork(2:l,1+l)
	 call dgetrs('n',lm1,1,rwork(2,zz+1),lp1,iwork,rwork(2,yl),lp1,info)
	 rwork(lp1,yl) = -one


!        --- Convex combination
	 call dsymv('u',lp1,one,rwork(1,1),lp1,rwork(1,y0),1,zero,rwork(1,y),1) ! rwork(1:l+1,y) = matmul(rwork(1:l+1,1:l+1),rwork(1:l+1,y0))
	 kappa0 = dsqrt(ddot(lp1,rwork(1,y0),1,rwork(1,y),1)) ! kappa0 = sqrt(dot_product(rwork(1:l+1,y0),rwork(1:l+1,y)))

	 call dsymv('u',lp1,one,rwork(1,1),lp1,rwork(1,yl),1,zero,rwork(1,y),1) ! rwork(1:l+1,y) = matmul(rwork(1:l+1,1:l+1),rwork(1:l+1,yl))
	 kappal = dsqrt(ddot(lp1,rwork(1,yl),1,rwork(1,y),1)) ! kappal = sqrt(dot_product(rwork(1:l+1,yl),rwork(1:l+1,y)))

	 call dsymv('u',lp1,one,rwork(1,1),lp1,rwork(1,y0),1,zero,rwork(1,y),1) ! rwork(1:l+1,y) = matmul(rwork(1:l+1,1:l+1),rwork(1:l+1,y0))
	 varrho = ddot(lp1,rwork(1,yl),1,rwork(1,y),1)/(kappa0*kappal)

	 hatgamma = sign(1.0_dp,varrho)*max(dabs(varrho),0.7_dp)*(kappa0/kappal)
	 call daxpy(lp1,(-hatgamma),rwork(1,yl),1,rwork(1,y0),1) ! rwork(1:l+1,y0) = rwork(1:l+1,y0) - hatgamma*rwork(1:l+1,yl)


!        --- Update
	 omega = rwork(lp1,y0)
	 call dgemv('n',n,l,(-one),work(1,u+1),n,rwork(2,y0),1,one,work(1,u),1) ! work(1:n,u) = work(1:n,u) - matmul(work(1:n,u+1:u+l),rwork(2:l+1,y0))
	 call dgemv('n',n,l,one,work(1,r),n,rwork(2,y0),1,one,x,1) ! x = x + matmul(work(1:n,r:r+l-1),rwork(2:l+1,y0))
	 call dgemv('n',n,l,(-one),work(1,r+1),n,rwork(2,y0),1,one,work(1,r),1) ! work(1:n,r) = work(1:n,r) - matmul(work(1:n,r+1:r+l),rwork(2:l+1,y0))

!** y0 has changed; compute y=Z*y0 once more
	 call dsymv('u',lp1,one,rwork(1,1),lp1,rwork(1,y0),1,zero,rwork(1,y),1) ! rwork(1:l+1,y) = matmul(rwork(1:l+1,1:l+1),rwork(1:l+1,y0))
	 rnrm = dsqrt(ddot(lp1,rwork(1,y0),1,rwork(1,y),1)) ! rnrm = sqrt(dot_product(rwork(1:l+1,y0),rwork(1:l+1,y)))


!     ================================
!     --- The reliable update part ---
!     ================================
!
	 mxnrmx = max(mxnrmx, rnrm); mxnrmr = max(mxnrmr, rnrm)
	 xpdt = (rnrm<delta*rnrm0 .and. rnrm0<mxnrmx)
	 rcmp = ((rnrm<delta*mxnrmr .and. rnrm0<mxnrmr) .or. xpdt)
	 if (rcmp) then
	    call matvec(n, x, work(1:n,r))
	    if (pcnd) call l_precond(n, work(1:n,r))
            nmatvec = nmatvec + 1

	    do i=1,n
	       work(i,r) =  work(i,bp) - work(i,r) ! work(1:n,r) =  work(1:n,bp) - work(1:n,r)
	    enddo
	    mxnrmr = rnrm
	    if (xpdt) then
	       call daxpy(n, one, x, 1, work(1,xp), 1) ! work(1:n,xp) = x + work(1:n,xp)
	       call dlaset('n', n, 1, zero, zero, x, 1) ! x = 0.0
	       call dcopy(n, work(1,r), 1, work(1,bp), 1) ! work(1:n,bp) = work(1:n,r)
	       mxnrmx = rnrm
	    endif
	 endif
      enddo

      deallocate(rwork,iwork)
!     =========================
!     --- End of iterations ---
!     =========================

      call daxpy(n, one, work(1,xp), 1, x, 1) ! x = work(1:n,xp) + x
      if (rnrm>toler*rnrm0) info = 1


!** compute the true residual:
! --------------------- One matvec can be saved by commenting out this:
!     --- Check stopping criterion
      call matvec(n, x, work(1:n,r))
      do i=1,n
	 work(i,r) = b(i) - work(i,r) ! work(1:n,r) = b - work(1:n,r)   
      enddo
      if (pcnd) call l_precond (n, work(1:n,r))
      rnrm = dnrm2(n, work(1,r), 1) ! rnrm = sqrt(dot_product(work(1:n,r),work(1:n,r)))
      nmatvec = nmatvec+1
! --------------------- One matvec can be saved by commenting out this:
      toler = rnrm/rnrm0; mxmatvec = nmatvec
      
      deallocate(work)

!----------------------------------------------------------------------------------------------------------------------------------!
END SUBROUTINE bicgstabl
!----------------------------------------------------------------------------------------------------------------------------------!

