! ------------------------------------------------------ !
! Bubel - superconductor.f90 - Krzysztof Kolasinski 2015
!
! Example based on Kwant tutorial:
! http://kwant-project.org/doc/1.0/tutorial/tutorial5
! ------------------------------------------------------ !
program supercond
use modunits     ! unit conversion tools
use modscatter   ! eigen values and transport
use modshape
implicit none
character(*),parameter :: output_folder = "superconductor_output/"
type(qscatter)             :: qt
type(qshape)               :: lead_shape
doubleprecision            :: zeros_vector(200)
doubleprecision            :: a_Emin,a_Emax
integer                    :: no_expected_states
integer ,parameter         :: nx = 30
integer ,parameter         :: ny = 10
doubleprecision,parameter  :: dx = 1.0 ! [nm]
integer , dimension(nx,ny) :: gindex ! converts local index (i,j) to global index
integer                    :: i,j,k,m
doubleprecision            :: lead_translation_vec(3),Ef
character(300) :: line
 ! Initalize system
call qt%init_system()
! ----------------------------------------------------------
! 1. Create mesh - loop over width and height of the lattice
! ----------------------------------------------------------
k      = 0
gindex = 0
do i = 1 , nx
do j = 1 , ny
    ! Initalize atom structure with position of the atom.
    call qt%qatom%init((/ (i-1) * dx , (j-1) * dx + (i-1) * dx * 0.0 , 0.0 * dx /),no_in_states=2)
    ! Add atom to the system.
    call qt%qsystem%add_atom(qt%qatom)
    k           = k + 1
    gindex(i,j) = k
enddo
enddo
! ----------------------------------------------------------
! 2. Construct logical connections between sites on the mesh.
! ----------------------------------------------------------
qt%qnnbparam%box = (/2*dx,2*dx,0.0D0/) ! do not search for the sites far than (-dx:+dx) direction
call qt%qsystem%make_lattice(qt%qnnbparam,c_matrix=coupling)

! ----------------------------------------------------------
! 3. Find eigenvalues of the system.
! You must provide range of energy (Emin,Emax) and
! number of expected states in that region. Eigen problem
! is solved with FEAST library.
! ----------------------------------------------------------
no_expected_states = 100
! we choose small enery window
a_Emin =0.0
a_Emax =0.2
call qt%qsystem%calc_eigenproblem(a_Emin,a_Emax,no_expected_states)
! Write founded eigenstates to file if there are states in the range (Emin,Emax)
if(qt%qsystem%no_eigenvalues > 0) then
zeros_vector = 0
open(unit=222,file=output_folder//"eigenvecs.dat")
do i = 1 , nx
do j = 1 , ny
    if(qt%qsystem%atoms(gindex(i,j))%bActive)then
    ! get unique ID of current site
    k = qt%qsystem%atoms(gindex(i,j))%globalIDs(2)  ! take spin = 2
    m = qt%qsystem%atoms(gindex(i,j))%globalIDs(1)  ! take spin = 1
    ! save total density
    write(222,"(500e20.6)"),qt%qsystem%atoms(gindex(i,j))%atom_pos,abs(qt%qsystem%eigenvecs(k,:))**2+abs(qt%qsystem%eigenvecs(m,:))**2
    else
    ! fill with zeros empty spaces
    write(222,"(500e20.6)"),qt%qsystem%atoms(gindex(i,j))%atom_pos,zeros_vector(1:qt%qsystem%no_eigenvalues)
    endif
enddo
    write(222,*),"" ! GNUPLOT necessary line break
enddo
close(222)
endif ! end of if are there eigenstates?
! Those can be viewed in Viewer
call qt%qsystem%save_data(output_folder//"eigenvectors.xml",array2d=abs(transpose(qt%qsystem%eigenvecs))**2)

! ----------------------------------------------------------
! 4. Use generated mesh to calculate the band structure
! in the region of homogenous lead.
! ----------------------------------------------------------
lead_translation_vec = (/  dx , 0.0D0 , 0.0D0 /)
call lead_shape%init_range_3d((/ -0.5*dx , 0.0D0 , 0.0D0 /),lead_translation_vec)
call qt%add_lead(lead_shape,lead_translation_vec)

lead_translation_vec = (/ -dx , 0.0D0 , 0.0D0 /)
call lead_shape%init_range_3d((/ (nx+0.5-1)*dx , 0.0D0 , 0.0D0 /),lead_translation_vec)
call qt%add_lead(lead_shape,lead_translation_vec)

a_Emin =-10.0
a_Emax = 10.0
call qt%leads(1)%bands(output_folder//"bands.dat",-M_PI,+M_PI,M_PI/160.0,a_Emin,a_Emax)

! Save lattice to file to see if constructed system is OK!
call qt%save_system(output_folder//"system.xml")

Ef = 1.0
QSYS_DEBUG_LEVEL = 1 ! tell me more
call qt%calculate_modes(Ef)
call qt%solve(1,Ef)

! Save calculated electron density to file
do i = 1 , size(qt%qauxvec)
    qt%qauxvec(i) = sum(qt%densities(:,i))
enddo
call qt%qsystem%save_data(output_folder//"densities.xml",array2d=qt%densities,array1d=qt%qauxvec)

print*,"Performing energy scan..."
open(unit=111,file=output_folder//"T.dat")
QSYS_DEBUG_LEVEL = 0 ! show me less
do Ef = -3.0 , 3.025 , 0.015
    ! Update hamiltonian elemenents value
    call qt%qsystem%update_lattice(c_matrix=coupling)
    call qt%calculate_modes(Ef)
    call qt%solve(1,Ef)

    print*,"Energy:",Ef,sum(qt%Tn(:))
    write(111,"(100f20.6)"),Ef,sum(qt%Tn(:))
enddo
close(111)

! ----------------------------------------------------------
! X. Clean memory...
! ----------------------------------------------------------

call qt%destroy_system()
print*,"Generating plots..."
print*,"Plotting band structure..."
call system("cd "//output_folder//"; ./plot_bands.py")
print*,"Plotting eigenvectors..."
call system("cd "//output_folder//"; ./plot_eigenvecs.py")
print*,"Plotting Transmission..."
call system("cd "//output_folder//"; ./plot_T.py")
print*,"Use Viewer program to see the structure and created leads."
contains

! ---------------------------------------------------------------------------
! Implement coupling
! Taken from Kwant tutorial: http://kwant-project.org/doc/1.0/tutorial/tutorial5
! ---------------------------------------------------------------------------
logical function coupling(atomA,atomB,coupling_mat)
    use modcommons
    implicit none
    type(qatom) :: atomA,atomB
    complex*16  :: coupling_mat(:,:) ! you must overwrite this variable
    ! local variables
    integer         :: xdiff,ydiff
    doubleprecision :: dydiff,dxdiff,t0,mu,Delta

    ! Calculate distance between atoms in units of dx.
    dxdiff = (atomA%atom_pos(1)-atomB%atom_pos(1))/dx
    dydiff = (atomA%atom_pos(2)-atomB%atom_pos(2))/dx
    ! Convert it to integers
    xdiff = NINT(dxdiff)
    ydiff = NINT(dydiff)
    ! default return value
    coupling       = .false.
    coupling_mat   = 0.0

    t0    = 1.0 ! hoping energy
    mu    = 0.7 ! chemical potential
    Delta = 0.1 ! superconducting order parameter

    if( xdiff == 0 .and. ydiff == 0 ) then
        coupling     = .true.
        coupling_mat = (4*t0 - mu)* MAT_SZ + Delta*MAT_SX
    else if( abs(xdiff) ==  1 .and. ydiff == 0 ) then
        coupling     = .true.
        coupling_mat = -t0 *(MAT_SZ)
    else if( xdiff ==  0 .and. abs(ydiff) == 1 ) then
        coupling     = .true.
        coupling_mat = -t0 *(MAT_SZ)
    endif
end function coupling
end program supercond


      subroutine rpt2cons_manifold(ixy,imp,maxm,meqn,mwaves,maux,
     &               mbc,mx,ql,qr,
     &               aux1,aux2,aux3,asdq,bmasdq,bpasdq)

      implicit none

      integer ixy, maxm, meqn,mwaves,mbc,mx,maux,imp

      double precision     ql(meqn,1-mbc:maxm+mbc)
      double precision     qr(meqn,1-mbc:maxm+mbc)
      double precision   asdq(meqn,1-mbc:maxm+mbc)
      double precision bmasdq(meqn,1-mbc:maxm+mbc)
      double precision bpasdq(meqn,1-mbc:maxm+mbc)
      double precision   aux1(maux,1-mbc:maxm+mbc)
      double precision   aux2(maux,1-mbc:maxm+mbc)
      double precision   aux3(maux,1-mbc:maxm+mbc)

      integer i, i1, k, idir, iface
      double precision vrrot, vlrot, g, vhat
      double precision nv(2), ul(2), ur(2)

c     # idir = direction of normal solve
c     # ixy = 1 --> idir = 0
c     # ixy = 2 --> idir = 1
      idir = ixy-1

c     # iface = 2*(2-ixy)
      if (ixy .eq. 1) then
         iface = 2  !! Bottom edge
      else
         iface = 0  !! left edge
      endif

      do i = 2-mbc, mx+mbc
c         # imp = 1 : i-1   (for apdq)
c         # imp = 2 : i     (for apdq)
          i1 = i-2+imp

c         # -----------------------------------------
c         # Lower faces - cell centered velocities
c         # -----------------------------------------

c         # left/right : 12,13
c         # bottom/top : 14,15
          g = aux2(14-2*idir,i1)

          nv(1) = aux2(8-4*idir,i1)
          nv(2) = aux2(9-4*idir,i1)

          ur(1) = aux2(2,i1)
          ur(2) = aux2(3,i1)

          ul(1) = aux1(2,i1)
          ul(2) = aux1(3,i1)

          vrrot = g*(nv(1)*ur(1) + nv(2)*ur(2))
          vlrot = g*(nv(1)*ul(1) + nv(2)*ul(2))

          vhat = (vrrot + vlrot)/2.0

          bmasdq(1,i) = min(vhat,0.d0)*asdq(1,i)

c         # -----------------------------------------
c         # Upper faces - cell centered velocities
c         # -----------------------------------------

          g = aux3(14-2*idir,i1)
          nv(1) = aux3(8-4*idir,i1)
          nv(2) = aux3(9-4*idir,i1)
          ur(1) = aux2(2,i1)
          ur(2) = aux2(3,i1)

          ul(1) = aux1(2,i1)
          ul(2) = aux1(3,i1)

          vrrot = g*(nv(1)*ur(1) + nv(2)*ur(2))
          vlrot = g*(nv(1)*ul(1) + nv(2)*ul(2))

          vhat = (vrrot + vlrot)/2.0

          bpasdq(1,i) = max(vhat,0.d0)*asdq(1,i)

      enddo

      return
      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine z_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     Performs line solves in Z direction by first factoring
c     the block-tridiagonal matrix into an upper triangular matrix,
c     and then performing back substitution to solve for the unknow
c     vectors of each line.
c
c     Make sure we treat elements zero to cell_size in the direction
c     of the sweep.
c---------------------------------------------------------------------

      include 'header.h'
      include 'work_lhs_vec.h'

      integer i, j, k, m, n, ksize

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      if (timeron) call timer_start(t_zsolve)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     This function computes the left hand side for the three z-factors
c---------------------------------------------------------------------

      ksize = grid_points(3)-1

c---------------------------------------------------------------------
c     Compute the indices for storing the block-diagonal matrix;
c     determine c (labeled f) and s jacobians
c---------------------------------------------------------------------
!$omp parallel do default(shared) shared(ksize)
!$omp& private(i,j,k,m,n)
      do j = 1, grid_points(2)-2
         do k = 0, ksize
            do i = 1, grid_points(1)-2

               tmp1 = 1.0d+00 / u(1,i,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               fjac(1,1,i,k) = 0.0d+00
               fjac(1,2,i,k) = 0.0d+00
               fjac(1,3,i,k) = 0.0d+00
               fjac(1,4,i,k) = 1.0d+00
               fjac(1,5,i,k) = 0.0d+00

               fjac(2,1,i,k) = - ( u(2,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(2,2,i,k) = u(4,i,j,k) * tmp1
               fjac(2,3,i,k) = 0.0d+00
               fjac(2,4,i,k) = u(2,i,j,k) * tmp1
               fjac(2,5,i,k) = 0.0d+00

               fjac(3,1,i,k) = - ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(3,2,i,k) = 0.0d+00
               fjac(3,3,i,k) = u(4,i,j,k) * tmp1
               fjac(3,4,i,k) = u(3,i,j,k) * tmp1
               fjac(3,5,i,k) = 0.0d+00

               fjac(4,1,i,k) = - (u(4,i,j,k)*u(4,i,j,k) * tmp2 )
     >              + c2 * qs(i,j,k)
               fjac(4,2,i,k) = - c2 *  u(2,i,j,k) * tmp1
               fjac(4,3,i,k) = - c2 *  u(3,i,j,k) * tmp1
               fjac(4,4,i,k) = ( 2.0d+00 - c2 )
     >              *  u(4,i,j,k) * tmp1
               fjac(4,5,i,k) = c2

               fjac(5,1,i,k) = ( c2 * 2.0d0 * square(i,j,k)
     >              - c1 * u(5,i,j,k) )
     >              * u(4,i,j,k) * tmp2
               fjac(5,2,i,k) = - c2 * ( u(2,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(5,3,i,k) = - c2 * ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(5,4,i,k) = c1 * ( u(5,i,j,k) * tmp1 )
     >              - c2
     >              * ( qs(i,j,k)
     >              + u(4,i,j,k)*u(4,i,j,k) * tmp2 )
               fjac(5,5,i,k) = c1 * u(4,i,j,k) * tmp1

               njac(1,1,i,k) = 0.0d+00
               njac(1,2,i,k) = 0.0d+00
               njac(1,3,i,k) = 0.0d+00
               njac(1,4,i,k) = 0.0d+00
               njac(1,5,i,k) = 0.0d+00

               njac(2,1,i,k) = - c3c4 * tmp2 * u(2,i,j,k)
               njac(2,2,i,k) =   c3c4 * tmp1
               njac(2,3,i,k) =   0.0d+00
               njac(2,4,i,k) =   0.0d+00
               njac(2,5,i,k) =   0.0d+00

               njac(3,1,i,k) = - c3c4 * tmp2 * u(3,i,j,k)
               njac(3,2,i,k) =   0.0d+00
               njac(3,3,i,k) =   c3c4 * tmp1
               njac(3,4,i,k) =   0.0d+00
               njac(3,5,i,k) =   0.0d+00

               njac(4,1,i,k) = - con43 * c3c4 * tmp2 * u(4,i,j,k)
               njac(4,2,i,k) =   0.0d+00
               njac(4,3,i,k) =   0.0d+00
               njac(4,4,i,k) =   con43 * c3 * c4 * tmp1
               njac(4,5,i,k) =   0.0d+00

               njac(5,1,i,k) = - (  c3c4
     >              - c1345 ) * tmp3 * (u(2,i,j,k)**2)
     >              - ( c3c4 - c1345 ) * tmp3 * (u(3,i,j,k)**2)
     >              - ( con43 * c3c4
     >              - c1345 ) * tmp3 * (u(4,i,j,k)**2)
     >              - c1345 * tmp2 * u(5,i,j,k)

               njac(5,2,i,k) = (  c3c4 - c1345 ) * tmp2 * u(2,i,j,k)
               njac(5,3,i,k) = (  c3c4 - c1345 ) * tmp2 * u(3,i,j,k)
               njac(5,4,i,k) = ( con43 * c3c4
     >              - c1345 ) * tmp2 * u(4,i,j,k)
               njac(5,5,i,k) = ( c1345 )* tmp1

            enddo
         enddo

c---------------------------------------------------------------------
c     zero the whole left hand side for starters
c     set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
         do i = 1, grid_points(1)-2
            do m = 1, 5
               do n = 1, 5
                  lhs(m,n,aa,i,0) = 0.0d0
                  lhs(m,n,bb,i,0) = 0.0d0
                  lhs(m,n,cc,i,0) = 0.0d0
                  lhs(m,n,aa,i,ksize) = 0.0d0
                  lhs(m,n,bb,i,ksize) = 0.0d0
                  lhs(m,n,cc,i,ksize) = 0.0d0
               end do
               lhs(m,m,bb,i,0) = 1.0d0
               lhs(m,m,bb,i,ksize) = 1.0d0
            end do
         enddo

c---------------------------------------------------------------------
c     now jacobians set, so form left hand side in z direction
c---------------------------------------------------------------------
         do k = 1, ksize-1
            do i = 1, grid_points(1)-2

               tmp1 = dt * tz1
               tmp2 = dt * tz2

               lhs(1,1,aa,i,k) = - tmp2 * fjac(1,1,i,k-1)
     >              - tmp1 * njac(1,1,i,k-1)
     >              - tmp1 * dz1
               lhs(1,2,aa,i,k) = - tmp2 * fjac(1,2,i,k-1)
     >              - tmp1 * njac(1,2,i,k-1)
               lhs(1,3,aa,i,k) = - tmp2 * fjac(1,3,i,k-1)
     >              - tmp1 * njac(1,3,i,k-1)
               lhs(1,4,aa,i,k) = - tmp2 * fjac(1,4,i,k-1)
     >              - tmp1 * njac(1,4,i,k-1)
               lhs(1,5,aa,i,k) = - tmp2 * fjac(1,5,i,k-1)
     >              - tmp1 * njac(1,5,i,k-1)

               lhs(2,1,aa,i,k) = - tmp2 * fjac(2,1,i,k-1)
     >              - tmp1 * njac(2,1,i,k-1)
               lhs(2,2,aa,i,k) = - tmp2 * fjac(2,2,i,k-1)
     >              - tmp1 * njac(2,2,i,k-1)
     >              - tmp1 * dz2
               lhs(2,3,aa,i,k) = - tmp2 * fjac(2,3,i,k-1)
     >              - tmp1 * njac(2,3,i,k-1)
               lhs(2,4,aa,i,k) = - tmp2 * fjac(2,4,i,k-1)
     >              - tmp1 * njac(2,4,i,k-1)
               lhs(2,5,aa,i,k) = - tmp2 * fjac(2,5,i,k-1)
     >              - tmp1 * njac(2,5,i,k-1)

               lhs(3,1,aa,i,k) = - tmp2 * fjac(3,1,i,k-1)
     >              - tmp1 * njac(3,1,i,k-1)
               lhs(3,2,aa,i,k) = - tmp2 * fjac(3,2,i,k-1)
     >              - tmp1 * njac(3,2,i,k-1)
               lhs(3,3,aa,i,k) = - tmp2 * fjac(3,3,i,k-1)
     >              - tmp1 * njac(3,3,i,k-1)
     >              - tmp1 * dz3
               lhs(3,4,aa,i,k) = - tmp2 * fjac(3,4,i,k-1)
     >              - tmp1 * njac(3,4,i,k-1)
               lhs(3,5,aa,i,k) = - tmp2 * fjac(3,5,i,k-1)
     >              - tmp1 * njac(3,5,i,k-1)

               lhs(4,1,aa,i,k) = - tmp2 * fjac(4,1,i,k-1)
     >              - tmp1 * njac(4,1,i,k-1)
               lhs(4,2,aa,i,k) = - tmp2 * fjac(4,2,i,k-1)
     >              - tmp1 * njac(4,2,i,k-1)
               lhs(4,3,aa,i,k) = - tmp2 * fjac(4,3,i,k-1)
     >              - tmp1 * njac(4,3,i,k-1)
               lhs(4,4,aa,i,k) = - tmp2 * fjac(4,4,i,k-1)
     >              - tmp1 * njac(4,4,i,k-1)
     >              - tmp1 * dz4
               lhs(4,5,aa,i,k) = - tmp2 * fjac(4,5,i,k-1)
     >              - tmp1 * njac(4,5,i,k-1)

               lhs(5,1,aa,i,k) = - tmp2 * fjac(5,1,i,k-1)
     >              - tmp1 * njac(5,1,i,k-1)
               lhs(5,2,aa,i,k) = - tmp2 * fjac(5,2,i,k-1)
     >              - tmp1 * njac(5,2,i,k-1)
               lhs(5,3,aa,i,k) = - tmp2 * fjac(5,3,i,k-1)
     >              - tmp1 * njac(5,3,i,k-1)
               lhs(5,4,aa,i,k) = - tmp2 * fjac(5,4,i,k-1)
     >              - tmp1 * njac(5,4,i,k-1)
               lhs(5,5,aa,i,k) = - tmp2 * fjac(5,5,i,k-1)
     >              - tmp1 * njac(5,5,i,k-1)
     >              - tmp1 * dz5

               lhs(1,1,bb,i,k) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(1,1,i,k)
     >              + tmp1 * 2.0d+00 * dz1
               lhs(1,2,bb,i,k) = tmp1 * 2.0d+00 * njac(1,2,i,k)
               lhs(1,3,bb,i,k) = tmp1 * 2.0d+00 * njac(1,3,i,k)
               lhs(1,4,bb,i,k) = tmp1 * 2.0d+00 * njac(1,4,i,k)
               lhs(1,5,bb,i,k) = tmp1 * 2.0d+00 * njac(1,5,i,k)

               lhs(2,1,bb,i,k) = tmp1 * 2.0d+00 * njac(2,1,i,k)
               lhs(2,2,bb,i,k) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(2,2,i,k)
     >              + tmp1 * 2.0d+00 * dz2
               lhs(2,3,bb,i,k) = tmp1 * 2.0d+00 * njac(2,3,i,k)
               lhs(2,4,bb,i,k) = tmp1 * 2.0d+00 * njac(2,4,i,k)
               lhs(2,5,bb,i,k) = tmp1 * 2.0d+00 * njac(2,5,i,k)

               lhs(3,1,bb,i,k) = tmp1 * 2.0d+00 * njac(3,1,i,k)
               lhs(3,2,bb,i,k) = tmp1 * 2.0d+00 * njac(3,2,i,k)
               lhs(3,3,bb,i,k) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(3,3,i,k)
     >              + tmp1 * 2.0d+00 * dz3
               lhs(3,4,bb,i,k) = tmp1 * 2.0d+00 * njac(3,4,i,k)
               lhs(3,5,bb,i,k) = tmp1 * 2.0d+00 * njac(3,5,i,k)

               lhs(4,1,bb,i,k) = tmp1 * 2.0d+00 * njac(4,1,i,k)
               lhs(4,2,bb,i,k) = tmp1 * 2.0d+00 * njac(4,2,i,k)
               lhs(4,3,bb,i,k) = tmp1 * 2.0d+00 * njac(4,3,i,k)
               lhs(4,4,bb,i,k) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(4,4,i,k)
     >              + tmp1 * 2.0d+00 * dz4
               lhs(4,5,bb,i,k) = tmp1 * 2.0d+00 * njac(4,5,i,k)

               lhs(5,1,bb,i,k) = tmp1 * 2.0d+00 * njac(5,1,i,k)
               lhs(5,2,bb,i,k) = tmp1 * 2.0d+00 * njac(5,2,i,k)
               lhs(5,3,bb,i,k) = tmp1 * 2.0d+00 * njac(5,3,i,k)
               lhs(5,4,bb,i,k) = tmp1 * 2.0d+00 * njac(5,4,i,k)
               lhs(5,5,bb,i,k) = 1.0d+00
     >              + tmp1 * 2.0d+00 * njac(5,5,i,k)
     >              + tmp1 * 2.0d+00 * dz5

               lhs(1,1,cc,i,k) =  tmp2 * fjac(1,1,i,k+1)
     >              - tmp1 * njac(1,1,i,k+1)
     >              - tmp1 * dz1
               lhs(1,2,cc,i,k) =  tmp2 * fjac(1,2,i,k+1)
     >              - tmp1 * njac(1,2,i,k+1)
               lhs(1,3,cc,i,k) =  tmp2 * fjac(1,3,i,k+1)
     >              - tmp1 * njac(1,3,i,k+1)
               lhs(1,4,cc,i,k) =  tmp2 * fjac(1,4,i,k+1)
     >              - tmp1 * njac(1,4,i,k+1)
               lhs(1,5,cc,i,k) =  tmp2 * fjac(1,5,i,k+1)
     >              - tmp1 * njac(1,5,i,k+1)

               lhs(2,1,cc,i,k) =  tmp2 * fjac(2,1,i,k+1)
     >              - tmp1 * njac(2,1,i,k+1)
               lhs(2,2,cc,i,k) =  tmp2 * fjac(2,2,i,k+1)
     >              - tmp1 * njac(2,2,i,k+1)
     >              - tmp1 * dz2
               lhs(2,3,cc,i,k) =  tmp2 * fjac(2,3,i,k+1)
     >              - tmp1 * njac(2,3,i,k+1)
               lhs(2,4,cc,i,k) =  tmp2 * fjac(2,4,i,k+1)
     >              - tmp1 * njac(2,4,i,k+1)
               lhs(2,5,cc,i,k) =  tmp2 * fjac(2,5,i,k+1)
     >              - tmp1 * njac(2,5,i,k+1)

               lhs(3,1,cc,i,k) =  tmp2 * fjac(3,1,i,k+1)
     >              - tmp1 * njac(3,1,i,k+1)
               lhs(3,2,cc,i,k) =  tmp2 * fjac(3,2,i,k+1)
     >              - tmp1 * njac(3,2,i,k+1)
               lhs(3,3,cc,i,k) =  tmp2 * fjac(3,3,i,k+1)
     >              - tmp1 * njac(3,3,i,k+1)
     >              - tmp1 * dz3
               lhs(3,4,cc,i,k) =  tmp2 * fjac(3,4,i,k+1)
     >              - tmp1 * njac(3,4,i,k+1)
               lhs(3,5,cc,i,k) =  tmp2 * fjac(3,5,i,k+1)
     >              - tmp1 * njac(3,5,i,k+1)

               lhs(4,1,cc,i,k) =  tmp2 * fjac(4,1,i,k+1)
     >              - tmp1 * njac(4,1,i,k+1)
               lhs(4,2,cc,i,k) =  tmp2 * fjac(4,2,i,k+1)
     >              - tmp1 * njac(4,2,i,k+1)
               lhs(4,3,cc,i,k) =  tmp2 * fjac(4,3,i,k+1)
     >              - tmp1 * njac(4,3,i,k+1)
               lhs(4,4,cc,i,k) =  tmp2 * fjac(4,4,i,k+1)
     >              - tmp1 * njac(4,4,i,k+1)
     >              - tmp1 * dz4
               lhs(4,5,cc,i,k) =  tmp2 * fjac(4,5,i,k+1)
     >              - tmp1 * njac(4,5,i,k+1)

               lhs(5,1,cc,i,k) =  tmp2 * fjac(5,1,i,k+1)
     >              - tmp1 * njac(5,1,i,k+1)
               lhs(5,2,cc,i,k) =  tmp2 * fjac(5,2,i,k+1)
     >              - tmp1 * njac(5,2,i,k+1)
               lhs(5,3,cc,i,k) =  tmp2 * fjac(5,3,i,k+1)
     >              - tmp1 * njac(5,3,i,k+1)
               lhs(5,4,cc,i,k) =  tmp2 * fjac(5,4,i,k+1)
     >              - tmp1 * njac(5,4,i,k+1)
               lhs(5,5,cc,i,k) =  tmp2 * fjac(5,5,i,k+1)
     >              - tmp1 * njac(5,5,i,k+1)
     >              - tmp1 * dz5

            enddo
         enddo

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     performs guaussian elimination on this cell.
c
c     assumes that unpacking routines for non-first cells
c     preload C' and rhs' from previous cell.
c
c     assumed send happens outside this routine, but that
c     c'(KMAX) and rhs'(KMAX) will be sent to next cell.
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     outer most do loops - sweeping in i direction
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     multiply c(i,j,0) by b_inverse and copy back to c
c     multiply rhs(0) by b_inverse(0) and copy to rhs
c---------------------------------------------------------------------
!dir$ ivdep
         do i = 1, grid_points(1)-2
            call binvcrhs( lhs(1,1,bb,i,0),
     >                        lhs(1,1,cc,i,0),
     >                        rhs(1,i,j,0) )
         enddo

c---------------------------------------------------------------------
c     begin inner most do loop
c     do all the elements of the cell unless last
c---------------------------------------------------------------------
         do k=1,ksize-1
!dir$ ivdep
            do i = 1, grid_points(1)-2

c---------------------------------------------------------------------
c     subtract A*lhs_vector(k-1) from lhs_vector(k)
c
c     rhs(k) = rhs(k) - A*rhs(k-1)
c---------------------------------------------------------------------
               call matvec_sub(lhs(1,1,aa,i,k),
     >                         rhs(1,i,j,k-1),rhs(1,i,j,k))

c---------------------------------------------------------------------
c     B(k) = B(k) - C(k-1)*A(k)
c     call matmul_sub(aa,i,j,k,c,cc,i,j,k-1,c,bb,i,j,k)
c---------------------------------------------------------------------
               call matmul_sub(lhs(1,1,aa,i,k),
     >                         lhs(1,1,cc,i,k-1),
     >                         lhs(1,1,bb,i,k))

c---------------------------------------------------------------------
c     multiply c(i,j,k) by b_inverse and copy back to c
c     multiply rhs(i,j,1) by b_inverse(i,j,1) and copy to rhs
c---------------------------------------------------------------------
               call binvcrhs( lhs(1,1,bb,i,k),
     >                        lhs(1,1,cc,i,k),
     >                        rhs(1,i,j,k) )

            enddo
         enddo

c---------------------------------------------------------------------
c     Now finish up special cases for last cell
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     rhs(ksize) = rhs(ksize) - A*rhs(ksize-1)
c---------------------------------------------------------------------
!dir$ ivdep
         do i = 1, grid_points(1)-2
            call matvec_sub(lhs(1,1,aa,i,ksize),
     >                         rhs(1,i,j,ksize-1),rhs(1,i,j,ksize))

c---------------------------------------------------------------------
c     B(ksize) = B(ksize) - C(ksize-1)*A(ksize)
c     call matmul_sub(aa,i,j,ksize,c,
c     $              cc,i,j,ksize-1,c,bb,i,j,ksize)
c---------------------------------------------------------------------
            call matmul_sub(lhs(1,1,aa,i,ksize),
     >                         lhs(1,1,cc,i,ksize-1),
     >                         lhs(1,1,bb,i,ksize))

c---------------------------------------------------------------------
c     multiply rhs(ksize) by b_inverse(ksize) and copy to rhs
c---------------------------------------------------------------------
            call binvrhs( lhs(1,1,bb,i,ksize),
     >                       rhs(1,i,j,ksize) )
         enddo

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     back solve: if last cell, then generate U(ksize)=rhs(ksize)
c     else assume U(ksize) is loaded in un pack backsub_info
c     so just use it
c     after call u(kstart) will be sent to next cell
c---------------------------------------------------------------------

         do k=ksize-1,0,-1
            do i = 1, grid_points(1)-2
               do m=1,BLOCK_SIZE
                  do n=1,BLOCK_SIZE
                     rhs(m,i,j,k) = rhs(m,i,j,k)
     >                    - lhs(m,n,cc,i,k)*rhs(n,i,j,k+1)
                  enddo
               enddo
            enddo
         enddo

      enddo
      if (timeron) call timer_stop(t_zsolve)

      return
      end


*     MB04BZ EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER            NIN, NOUT
      PARAMETER          ( NIN = 5, NOUT = 6 )
      INTEGER            NMAX
      PARAMETER          ( NMAX = 50 )
      INTEGER            LDA, LDB, LDDE, LDFG, LDQ, LDWORK, LZWORK
      PARAMETER          ( LDA  = NMAX, LDB = NMAX, LDDE = NMAX,
     $                     LDFG = NMAX, LDQ = 2*NMAX,
     $                     LDWORK = 11*NMAX*NMAX + 2*NMAX,
     $                     LZWORK = 8*NMAX + 4 )
*
*     .. Local Scalars ..
      CHARACTER          COMPQ, JOB
      INTEGER            I, INFO, J, M, N
*
*     .. Local Arrays ..
      COMPLEX*16         A(  LDA,  NMAX ), B(  LDB,  NMAX ),
     $                   DE( LDDE, NMAX ), FG( LDFG, NMAX ),
     $                   Q( LDQ, 2*NMAX ), ZWORK( LZWORK )
      DOUBLE PRECISION   ALPHAI( NMAX ), ALPHAR( NMAX ),
     $                   BETA(   NMAX ), DWORK( LDWORK )
      INTEGER            IWORK( 2*NMAX+3 )
      LOGICAL            BWORK( NMAX )
*
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*
*     .. External Subroutines ..
      EXTERNAL           MB04BZ
*
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*
*     .. Executable Statements ..
*
      WRITE( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read in the data.
      READ( NIN, FMT = * )
      READ( NIN, FMT = * ) JOB, COMPQ, N
      IF( N.LT.0 .OR. N.GT.NMAX .OR. MOD( N, 2 ).NE.0 ) THEN
         WRITE( NOUT, FMT = 99998 ) N
      ELSE
         M = N/2
         READ( NIN, FMT = * ) ( (  A( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( DE( I, J ), J = 1, M+1 ), I = 1, M )
         READ( NIN, FMT = * ) ( (  B( I, J ), J = 1, M   ), I = 1, M )
         READ( NIN, FMT = * ) ( ( FG( I, J ), J = 1, M+1 ), I = 1, M )
*        Compute the eigenvalues of a complex skew-Hamiltonian/
*        Hamiltonian pencil.
         CALL MB04BZ( JOB, COMPQ, N, A, LDA, DE, LDDE, B, LDB, FG, LDFG,
     $                Q, LDQ, ALPHAR, ALPHAI, BETA, IWORK, DWORK,
     $                LDWORK, ZWORK, LZWORK, BWORK, INFO )
*
         IF( INFO.NE.0 ) THEN
            WRITE( NOUT, FMT = 99997 ) INFO
         ELSE
            IF( LSAME( JOB, 'T' ) ) THEN
               WRITE( NOUT, FMT = 99996 )
               DO 10 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( A( I, J ), J = 1, N )
   10          CONTINUE
               WRITE( NOUT, FMT = 99994 )
               DO 20 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( DE( I, J ), J = 1, N )
   20          CONTINUE
               WRITE( NOUT, FMT = 99993 )
               DO 30 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( B( I, J ), J = 1, N )
   30          CONTINUE
               WRITE( NOUT, FMT = 99992 )
               DO 40 I = 1, N
                  WRITE( NOUT, FMT = 99995 ) ( FG( I, J ), J = 1, N )
   40          CONTINUE
            END IF
            IF( LSAME( COMPQ, 'C' ) ) THEN
               WRITE( NOUT, FMT = 99991 )
               DO 50 I = 1, 2*N
                  WRITE( NOUT, FMT = 99995 ) ( Q( I, J ), J = 1, 2*N )
   50          CONTINUE
            END IF
            WRITE( NOUT, FMT = 99990 )
            WRITE( NOUT, FMT = 99989 ) ( ALPHAR( I ), I = 1, N )
            WRITE( NOUT, FMT = 99988 )
            WRITE( NOUT, FMT = 99989 ) ( ALPHAI( I ), I = 1, N )
            WRITE( NOUT, FMT = 99987 )
            WRITE( NOUT, FMT = 99989 ) (   BETA( I ), I = 1, N )
         END IF
      END IF
      STOP
*
99999 FORMAT ( 'MB04BZ EXAMPLE PROGRAM RESULTS', 1X )
99998 FORMAT ( 'N is out of range.', /, 'N = ', I5 )
99997 FORMAT ( 'INFO on exit from MB04BZ = ', I2 )
99996 FORMAT (/'The matrix A on exit is ' )
99995 FORMAT (20( 1X, F9.4, SP, F9.4, S, 'i ') )
99994 FORMAT (/'The matrix D on exit is ' )
99993 FORMAT (/'The matrix B on exit is ' )
99992 FORMAT (/'The matrix F on exit is ' )
99991 FORMAT (/'The matrix Q is ' )
99990 FORMAT (/'The vector ALPHAR is ' )
99989 FORMAT ( 50( 1X, F8.4 ) )
99988 FORMAT (/'The vector ALPHAI is ' )
99987 FORMAT (/'The vector BETA is ' )
      END