      subroutine twixt(s,gma,gmb,gmc,gmd,xbl,kat,kbl)
!     to determine interpolation coefficients
      use kinddefine
      implicit none
      integer(kind=K4) :: j,l
      integer(kind=K4),intent(in) :: kat
      integer(kind=K4),intent(out) :: kbl
      real(kind=K8) :: ds,dst,dstu,dt,dtu,du,xbb
      real(kind=K8),intent(out) :: gma,gmb,gmc,gmd
      real(kind=K8),intent(in) :: xbl
      real(kind=K8),dimension(200),intent(in) :: s
      do l=1,kat
       if(s(kat-l).lt.xbl) goto 2
      enddo
2     j=kat-l+1
      xbb=s(j)-xbl
      kbl=j+1
      du=s(j+1)-s(j)
      dt=s(j)-s(j-1)
      ds=s(j-1)-s(j-2)
      dst=ds+dt
      dstu=dst+du
      dtu=dt+du
      gma=-xbb*(dt-xbb)*(du+xbb)/ds/dst/dstu
      gmb=xbb*(dst-xbb)*(du+xbb)/ds/dt/dtu
      gmc=(dst-xbb)*(dt-xbb)*(du+xbb)/dst/dt/du
      gmd=-xbb*(dst-xbb)*(dt-xbb)/dstu/dtu/du
      end subroutine twixt


!!!    This program sloves Lid Driven Cavity Flow problem using Lattice Boltzmann Method
!!!    Lattice Boltzmann Equation with MRT-LBE model

! block arrangement is same as the data arrangement

program main
    use mpi
    use commondata
    implicit none
    real(8) :: start, finish
    real(8) :: start_time, end_time
    integer :: name_len, stride
    character(len=MPI_MAX_PROCESSOR_NAME) :: processor_name

    call MPI_Init(rc)

    call MPI_Comm_size(MPI_COMM_WORLD, num_process, rc)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, rc)
    call MPI_Get_processor_name(processor_name, name_len, rc)

    !!! decomposition the domain
    call MPI_Dims_create(num_process, 3, dims, rc)
    call MPI_Cart_create(MPI_COMM_WORLD, 3, dims, periods, .true., comm3d, rc)
    if(rank == 0) then
        write(*,*) "Using ", num_process, "processers."
        write(*,*) "dimens is x*y*z = ", dims(0), "x", dims(1), "x", dims(2)
    endif

    ! get my new rank in decomposition
    call MPI_Comm_rank(comm3d, rank3d, rc)
    ! write(*,*) "process ", rank3d, " of total ", num_process, "is alive."

    ! determain sub-domain size
    call MPI_Cart_get(comm3d, 3, dims, periods, coords, rc)
    call decompose_1d(total_nx, nx, coords(0), dims(0))
    call decompose_1d(total_ny, ny, coords(1), dims(1))
    call decompose_1d(total_nz, nz, coords(2), dims(2))
    ! write(*,*) "coords = ", coords(1), coords(2), coords(3), "nx*ny = ", nx, ny, nz

    ! get the neighbors
    call MPI_Cart_shift(comm3d, 0, 1, nbr_surface(2), nbr_surface(1), rc)
    call MPI_Cart_shift(comm3d, 1, 1, nbr_surface(4), nbr_surface(3), rc)
    call MPI_Cart_shift(comm3d, 2, 1, nbr_surface(6), nbr_surface(5), rc)
    ! write(*,*) "I'm process ", rank3d, "My neighbor surfaces are", nbr_surface(1), nbr_surface(2), nbr_surface(3), nbr_surface(4), nbr_surface(5), nbr_surface(6)
    call MPI_Cart_find_corners()

    ! construct the datatype for the exchange
    ! line data parallel x direction (don't exchange in x direction)
    call MPI_Type_vector(nx, 1, 19, MPI_REAL8, line_x, rc)
    call MPI_Type_commit(line_x, rc)
    ! line data parallel y direction (don't exchange in y direction)
    call MPI_Type_vector(ny, 1, 19 * (nx+2), MPI_REAL8, line_y, rc)
    call MPI_Type_commit(line_y, rc)
    ! line data parallel z direction (don't exchange in z direction)
    call MPI_Type_vector(nz, 1, 19 * (nx+2) * (ny+2), MPI_REAL8, line_z, rc)
    call MPI_Type_commit(line_z, rc)

    ! surface data exchange in x direction -- line_y * nz, stride = 19*(nx+2)*(ny+2)
    stride = 19 * (nx+2) * (ny+2)
    call MPI_Type_create_hvector(nz, 1, stride * sizeof(start), line_y, surface_x, rc)
    call MPI_Type_commit(surface_x, rc)
    ! surface data exchange in y direction -- line_x * nz, stride = 19*(nx+2)*(ny+2)
    stride = 19 * (nx+2) * (ny+2)
    call MPI_Type_create_hvector(nz, 1, stride * sizeof(start), line_x, surface_y, rc)
    call MPI_Type_commit(surface_y, rc)
    ! surface data exchange in z direction -- line_x * ny, stride = 19*(nx+2)
    stride = 19 * (nx+2)
    call MPI_Type_create_hvector(ny, 1, stride * sizeof(start), line_x, surface_z, rc)
    call MPI_Type_commit(surface_z, rc)

    call initial()

    ! call output_field()
    ! call output_velocity()

    call CPU_TIME(start)

    call MPI_Barrier(MPI_COMM_WORLD, rc)
    start_time = MPI_Wtime()

    do while((errorU.GT.eps).AND.(itc.LE.itc_max))

        itc = itc+1

        call collision()

        call message_passing_sendrecv()

        call streaming()

        call bounceback()

        call macro()

        if(MOD(itc,2000).EQ.0) then
            call check()
        endif

    enddo

    call MPI_Barrier(MPI_COMM_WORLD, rc)
    end_time = MPI_Wtime()

    call CPU_TIME(finish)

    if (rank == 0) then
        write(*,*) "Time (CPU) = ", real(finish-start), "s"
        write(*,*) "Wall time = ", real(end_time - start_time), "s"
    endif

    itc = itc+1
    ! call output_field()
    ! call output_velocity()

    if (rank == 0) then
        write(*,*) "Deallocate Array..."
    endif

    deallocate(u)
    deallocate(v)
    deallocate(w)
    deallocate(rho)
    deallocate(up)
    deallocate(vp)
    deallocate(wp)
    deallocate(f)
    deallocate(f_post)

     if (rank == 0) then
        write(*,*) "    "

        write(*,*) "Successfully: DNS completed!"
    endif

    call MPI_Finalize(rc)

end program main

subroutine decompose_1d(total_n, local_n, rank, num_process)
    implicit none
    integer, intent(in) :: total_n, rank, num_process
    integer, intent(out) :: local_n

    local_n = total_n / num_process

    if (rank < MOD(total_n, num_process)) then
        local_n = local_n + 1
    endif

end subroutine decompose_1d

subroutine MPI_Cart_find_corners()
    use mpi
    use commondata
    implicit none
    integer :: alpha

    ! name the neighbor line by the discrete velocity
    do alpha = 7, 18
        call MPI_Cart_shift_3d(ex(alpha), ey(alpha), ez(alpha), nbr_line(alpha))
    enddo

end subroutine MPI_Cart_find_corners

subroutine MPI_Cart_shift_3d(idx0, idx1, idx2, corner_rank)
    use mpi
    use commondata
    implicit none
    integer, intent(in) :: idx0, idx1, idx2
    integer, intent(out) :: corner_rank
    integer :: new_coords(0:2)

    new_coords(0) = coords(0) + idx0
    new_coords(1) = coords(1) + idx1
    new_coords(2) = coords(2) + idx2

    if (new_coords(0) < 0 .OR. new_coords(0) > dims(0)-1) then
        ! beyond the dims_0 boundary
        if (periods(0) == .false.) then
            corner_rank = MPI_PROC_NULL
            return
        else
            new_coords(0) = mod(new_coords(0) + dims(0), dims(0))
        endif
    else if (new_coords(1) < 0 .OR. new_coords(1) > dims(1)-1) then
        ! beyond the dims_1 boundary
        if (periods(1) == .false.) then
            corner_rank = MPI_PROC_NULL
            return
        else
            new_coords(1) = mod(new_coords(1) + dims(1), dims(1))
        endif
    else if (new_coords(2) < 0 .OR. new_coords(2) > dims(2)-1) then
        ! beyond the dims_2 boundary
        if (periods(2) == .false.) then
            corner_rank = MPI_PROC_NULL
            return
        else
            new_coords(2) = mod(new_coords(2) + dims(2), dims(2))
        endif
    endif

    call MPI_Cart_rank(comm3d, new_coords, corner_rank, rc)

end subroutine MPI_Cart_shift_3d


program main
  use refurbished, only: rocket, dp
  implicit none

  integer :: i
  real(dp), allocatable :: output(:,:)

  integer file_unit

  real(dp) dt_, t_max_
  real(dp) c_p_, MW_
  real(dp) temperature_, pressure_
  real(dp) T_flame_, r_ref_, n_
  real(dp) id_, od_, length_, rho_solid_
  real(dp) dia_, C_f_

  namelist/numerics_list/ dt_, t_max_
  namelist/gas_list/ c_p_, MW_
  namelist/state_list/  temperature_, pressure_
  namelist/combustion_list/ T_flame_, r_ref_, n_
  namelist/grain_list/ id_, od_, length_, rho_solid_
  namelist/nozzle_list/ dia_, C_f_

  open(newunit=file_unit, file="rocket.inp", status="old")

  read(file_unit, nml=numerics_list)
  read(file_unit, nml=gas_list)
  read(file_unit, nml=state_list)
  read(file_unit, nml=combustion_list)
  read(file_unit, nml=grain_list)
  read(file_unit, nml=nozzle_list)

  close(file_unit)

  output = rocket( &
      dt_, &
      t_max_, &
      c_p_, &
      MW_, &
      temperature_, &
      pressure_, &
      T_flame_, &
      r_ref_, &
      n_, &
      id_, &
      od_, &
      length_, &
      rho_solid_, &
      dia_, &
      C_f_)
  do i = lbound(output, 1), ubound(output, 1)
      print *, output(i,:)
  end do
end program


      subroutine gehrd(min_lwork,max_lwork,prefix,n,lo,hi)
      integer min_lwork,max_lwork,n,lo,hi
      character prefix
c
c     Returned maxwrk is acctually optimal lwork.
c

      INTEGER NB
      EXTERNAL ILAENV
      INTRINSIC MIN

      NB = MIN( 64, ILAENV( 1, prefix // 'GEHRD', ' ', n, lo, hi, -1 ) )
      max_lwork = n * NB
      min_lwork = MIN(max_lwork,MAX(1,n))

      end

      subroutine gesdd(min_lwork,max_lwork,prefix,m,n,compute_uv)
      integer min_lwork,max_lwork,m,n,compute_uv
      character prefix

      INTEGER MINMN, MNTHR, MINWRK, MAXWRK, SMLSIZ, BDSPAC, BDSPAN
      INTEGER            ILAENV, WRKBL
      EXTERNAL           ILAENV
      INTRINSIC          INT, MAX, MIN

      MINMN = MIN( M, N )
      MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
      MINWRK = 1
      MAXWRK = 1
      SMLSIZ = ILAENV( 9, prefix // 'GESDD', ' ', 0, 0, 0, 0 )
      IF( M.GE.N ) THEN
*
*           Compute space needed for DBDSDC
*
         BDSPAC = 3*N*N + 7*N
         BDSPAN = MAX( 12*N+4, 8*N+2+SMLSIZ*( SMLSIZ+8 ) )
         IF( M.GE.MNTHR ) THEN
            IF (compute_uv.eq.0) THEN
*
*     Path 1 (M much larger than N, JOBZ='N')
*
               MAXWRK = N + N*ILAENV( 1, prefix // 'GEQRF', ' ',
     $              M, N, -1,
     $              -1 )
               MAXWRK = MAX( MAXWRK, 3*N+2*N*
     $              ILAENV( 1, prefix // 'GEBRD', ' ',
     $              N, N, -1, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC )
               MINWRK = BDSPAC
            ELSE
*
*     Path 4 (M much larger than N, JOBZ='A')
*
               WRKBL = N + N*ILAENV( 1, prefix // 'GEQRF', ' ',
     $              M, N, -1, -1 )
               WRKBL = MAX( WRKBL, N+M*ILAENV( 1, prefix // 'ORGQR',
     $              ' ', M,
     $              M, N, -1 ) )
               WRKBL = MAX( WRKBL, 3*N+2*N*
     $              ILAENV( 1, prefix // 'GEBRD', ' ',
     $              N, N, -1, -1 ) )
               WRKBL = MAX( WRKBL, 3*N+N*
     $              ILAENV( 1, prefix // 'ORMBR', 'QLN',
     $              N, N, N, -1 ) )
               WRKBL = MAX( WRKBL, 3*N+N*
     $              ILAENV( 1, prefix // 'ORMBR', 'PRT',
     $              N, N, N, -1 ) )
               WRKBL = MAX( WRKBL, BDSPAC+2*N )
               MAXWRK = N*N + WRKBL
               MINWRK = BDSPAC + N*N + M + N
            ENDIF
         ELSE
*
*     Path 5 (M at least N, but not much larger)
*
            WRKBL = 3*N + ( M+N )*ILAENV( 1, prefix // 'GEBRD', ' ',
     $           M, N, -1, -1)
            IF (compute_uv.eq.0) THEN
               MAXWRK = MAX(WRKBL,BDSPAC + 3*N)
               MINWRK = 3*N + MAX(M,BDSPAC)
            ELSE
               MAXWRK = MAX( MAXWRK, 3*N+M*
     $              ILAENV( 1, prefix // 'ORMBR', 'QLN',
     $              M, M, N, -1 ) )
               MAXWRK = MAX( MAXWRK, 3*N+N*
     $              ILAENV( 1, prefix // 'ORMBR', 'PRT',
     $              N, N, N, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC+2*N+M )
               MINWRK = BDSPAC + 2*N + M
            ENDIF
         ENDIF
      ELSE
*
*     Compute space needed for DBDSDC
*
         BDSPAC = 3*M*M + 7*M
         BDSPAN = MAX( 12*M+4, 8*M+2+SMLSIZ*( SMLSIZ+8 ) )
         IF( N.GE.MNTHR ) THEN
            IF( compute_uv.eq.0 ) THEN
*
*     Path 1t (N much larger than M, JOBZ='N')
*
               MAXWRK = M + M*ILAENV( 1, prefix // 'GELQF', ' ',
     $              M, N, -1,
     $              -1 )
               MAXWRK = MAX( MAXWRK, 3*M+2*M*
     $              ILAENV( 1, prefix // 'GEBRD', ' ',
     $              M, M, -1, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC )
               MINWRK = BDSPAC
            ELSE
*
*     Path 4t (N much larger than M, JOBZ='A')
*
               WRKBL = M + M*ILAENV( 1, prefix // 'GELQF', ' ',
     $              M, N, -1, -1 )
               WRKBL = MAX( WRKBL, M+N*ILAENV( 1, prefix // 'ORGLQ',
     $              ' ', N,
     $              N, M, -1 ) )
               WRKBL = MAX( WRKBL, 3*M+2*M*
     $              ILAENV( 1, prefix // 'GEBRD', ' ',
     $              M, M, -1, -1 ) )
               WRKBL = MAX( WRKBL, 3*M+M*
     $              ILAENV( 1, prefix // 'ORMBR', 'QLN',
     $              M, M, M, -1 ) )
               WRKBL = MAX( WRKBL, 3*M+M*
     $              ILAENV( 1, prefix // 'ORMBR', 'PRT',
     $              M, M, M, -1 ) )
               WRKBL = MAX( WRKBL, BDSPAC+2*M )
               MAXWRK = WRKBL + M*M
               MINWRK = BDSPAC + M*M + M + N
            ENDIF
         ELSE
            WRKBL = 3*M + ( M+N )*ILAENV( 1, prefix // 'GEBRD', ' ',
     $           M, N, -1,
     $           -1 )
            IF (compute_uv.eq.0) THEN
               MAXWRK = MAX(WRKBL,BDSPAC + 3*M)
               MINWRK = 3*M + MAX(N,BDSPAC)
            ELSE
               MAXWRK = MAX( MAXWRK, 3*M+M*
     $              ILAENV( 1, prefix // 'ORMBR', 'QLN',
     $              M, M, N, -1 ) )
               MAXWRK = MAX( MAXWRK, 3*M+N*
     $              ILAENV( 1, prefix // 'ORMBR', 'PRT',
     $              N, N, M, -1 ) )
               MAXWRK = MAX( MAXWRK, BDSPAC+2*M )
               MINWRK = BDSPAC + 2*M + N
            ENDIF
         ENDIF
      ENDIF
      min_lwork = MINWRK
      max_lwork = MAX(MINWRK,MAXWRK)
      end

      subroutine gelss(min_lwork,max_lwork,prefix,m,n,nrhs)

      integer min_lwork,max_lwork,m,n,nrhs
      character prefix

      INTEGER MAXWRK, MINMN, MINWRK, MM, MNTHR
      INTEGER ILAENV, BDSPAC, MAXMN
      EXTERNAL ILAENV
      INTRINSIC          MAX, MIN

      MINMN = MIN( M, N )
      MAXMN = MAX( M, N )
      MNTHR = ILAENV( 6, prefix // 'GELSS', ' ', M, N, NRHS, -1 )
      MINWRK = 1
      MAXWRK = 0
      MM = M
      IF( M.GE.N .AND. M.GE.MNTHR ) THEN
*
*     Path 1a - overdetermined, with many more rows than columns
*
         MM = N
         MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, prefix //  'GEQRF', ' ',
     $        M, N, -1, -1 ) )
         MAXWRK = MAX( MAXWRK, N+NRHS*
     $        ILAENV( 1, prefix //  'ORMQR', 'LT', M, NRHS, N, -1 ) )
      END IF
      IF( M.GE.N ) THEN
*
*     Path 1 - overdetermined or exactly determined
*
*     Compute workspace neede for BDSQR
*
         BDSPAC = MAX( 1, 5*N )
         MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
     $        ILAENV( 1, prefix // 'GEBRD', ' ', MM, N, -1, -1 ) )
         MAXWRK = MAX( MAXWRK, 3*N+NRHS*
     $        ILAENV( 1, prefix // 'ORMBR', 'QLT', MM, NRHS, N, -1 ) )
         MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
     $        ILAENV( 1, prefix // 'ORGBR', 'P', N, N, N, -1 ) )
         MAXWRK = MAX( MAXWRK, BDSPAC )
         MAXWRK = MAX( MAXWRK, N*NRHS )
         MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC )
         MAXWRK = MAX( MINWRK, MAXWRK )
      END IF

      IF( N.GT.M ) THEN
*
*     Compute workspace neede for DBDSQR
*
         BDSPAC = MAX( 1, 5*M )
         MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
         IF( N.GE.MNTHR ) THEN
*
*     Path 2a - underdetermined, with many more columns
*     than rows
*
            MAXWRK = M + M*ILAENV( 1, prefix // 'GELQF', ' ',
     $           M, N, -1, -1 )
            MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
     $           ILAENV( 1, prefix //  'GEBRD', ' ', M, M, -1, -1 ) )
            MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
     $           ILAENV( 1, prefix // 'ORMBR', 'QLT', M, NRHS, M, -1 ))
            MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
     $           ILAENV( 1, prefix // 'ORGBR', 'P', M, M, M, -1 ) )
            MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC )
            IF( NRHS.GT.1 ) THEN
               MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
            ELSE
               MAXWRK = MAX( MAXWRK, M*M+2*M )
            END IF
            MAXWRK = MAX( MAXWRK, M+NRHS*
     $           ILAENV( 1, prefix // 'ORMLQ', 'LT', N, NRHS, M, -1 ) )

         ELSE
*
*     Path 2 - underdetermined
*
            MAXWRK = 3*M + ( N+M )*ILAENV( 1, prefix // 'GEBRD', ' ',
     $           M, N, -1, -1 )
            MAXWRK = MAX( MAXWRK, 3*M+NRHS*
     $           ILAENV( 1, prefix // 'ORMBR', 'QLT', M, NRHS, M, -1 ) )
            MAXWRK = MAX( MAXWRK, 3*M+M*
     $           ILAENV( 1, prefix // 'ORGBR', 'P', M, N, M, -1 ) )
            MAXWRK = MAX( MAXWRK, BDSPAC )
            MAXWRK = MAX( MAXWRK, N*NRHS )
         END IF
      END IF
      MAXWRK = MAX( MINWRK, MAXWRK )
      MINWRK = MAX( MINWRK, 1 )

      min_lwork = MINWRK
      max_lwork = MAXWRK
      end

      subroutine getri(min_lwork,max_lwork,prefix,n)
      integer min_lwork,max_lwork,n
      character prefix
      INTEGER ILAENV, NB
      EXTERNAL ILAENV
      NB = ILAENV( 1, prefix // 'GETRI', ' ', N, -1, -1, -1 )
      min_lwork = N
      max_lwork = N*NB
      end

      subroutine geev(min_lwork,max_lwork,prefix,n,
     $     compute_vl,compute_vr)

      integer min_lwork,max_lwork,n,compute_vl,compute_vr
      character prefix

      LOGICAL WANTVL, WANTVR
      INTEGER ILAENV, MINWRK, MAXWRK, MAXB, HSWORK, K
      EXTERNAL ILAENV
      INTRINSIC          MAX, MIN

      WANTVL = compute_vl.eq.1
      WANTVR = compute_vr.eq.1

      MINWRK = 1
      MAXWRK = 2*N + N*ILAENV( 1, prefix // 'GEHRD', ' ', N, 1, N, 0 )
      IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
         MINWRK = MAX( 1, 3*N )
         MAXB = MAX( ILAENV( 8, prefix // 'HSEQR', 'EN', N, 1, N, -1 )
     $        , 2 )
         K = MIN( MAXB, N, MAX( 2, ILAENV( 4, prefix // 'HSEQR', 'EN', N
     $        , 1,  N, -1 ) ) )
         HSWORK = MAX( K*( K+2 ), 2*N )
         MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
      ELSE
         MINWRK = MAX( 1, 4*N )
         MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
     $        ILAENV( 1, prefix // 'ORGHR', ' ', N, 1, N, -1 ) )
         MAXB = MAX( ILAENV( 8, prefix // 'HSEQR', 'SV', N, 1, N, -1 ),
     $        2  )
         K = MIN( MAXB, N, MAX( 2, ILAENV( 4, prefix // 'HSEQR', 'SV', N
     $        , 1, N, -1 ) ) )
         HSWORK = MAX( K*( K+2 ), 2*N )
         MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
         MAXWRK = MAX( MAXWRK, 4*N )
      END IF
      min_lwork = MINWRK
      max_lwork = MAXWRK
      end

      subroutine heev(min_lwork,max_lwork,prefix,n,lower)

      integer min_lwork,max_lwork,n,lower
      character prefix

      CHARACTER UPLO
      INTEGER ILAENV, NB
      EXTERNAL ILAENV
      INTRINSIC MAX

      UPLO = 'L'
      if (lower.eq.0) then
        UPLO = 'U'
      endif

      NB = ILAENV( 1, prefix // 'HETRD', UPLO, N, -1, -1, -1 )

      min_lwork = MAX(1,2*N-1)
      max_lwork = MAX( 1, ( NB+1 )*N )

      end

      subroutine syev(min_lwork,max_lwork,prefix,n,lower)

      integer min_lwork,max_lwork,n,lower
      character prefix

      CHARACTER UPLO
      INTEGER ILAENV, NB
      EXTERNAL ILAENV
      INTRINSIC MAX

      UPLO = 'L'
      if (lower.eq.0) then
        UPLO = 'U'
      end if

      NB = ILAENV( 1, prefix // 'SYTRD', UPLO, N, -1, -1, -1 )

      min_lwork = MAX(1,3*N-1)
      max_lwork = MAX( 1, ( NB+2 )*N )

      end

      subroutine gees(min_lwork,max_lwork,prefix,n,compute_v)

      integer min_lwork,max_lwork,n,compute_v
      character prefix

      INTEGER            HSWORK, MAXWRK, MINWRK, MAXB, K
      INTEGER            ILAENV
      EXTERNAL           ILAENV
      INTRINSIC          MAX, MIN

      MAXWRK = N + N*ILAENV( 1, prefix // 'GEHRD', ' ', N, 1, N, 0 )
      MINWRK = MAX( 1, 2*N )
      IF( compute_v.eq.0 ) THEN
         MAXB = MAX( ILAENV( 8, prefix // 'HSEQR',
     $        'SN', N, 1, N, -1 ), 2 )
         K = MIN( MAXB, N, MAX( 2, ILAENV( 4, prefix // 'HSEQR',
     $    'SN', N, 1, N, -1 ) ) )
         HSWORK = MAX( K*( K+2 ), 2*N )
         MAXWRK = MAX( MAXWRK, HSWORK, 1 )
      ELSE
         MAXWRK = MAX( MAXWRK, N+( N-1 )*
     $        ILAENV( 1, prefix // 'UNGHR', ' ', N, 1, N, -1 ) )
         MAXB = MAX( ILAENV( 8, prefix // 'HSEQR',
     $        'EN', N, 1, N, -1 ), 2 )
         K = MIN( MAXB, N, MAX( 2, ILAENV( 4, prefix // 'HSEQR',
     $        'EN', N, 1, N, -1 ) ) )
         HSWORK = MAX( K*( K+2 ), 2*N )
         MAXWRK = MAX( MAXWRK, HSWORK, 1 )
      END IF

      min_lwork = MINWRK
      max_lwork = MAXWRK

      end

      subroutine geqrf(min_lwork,max_lwork,prefix,m,n)

      integer min_lwork,max_lwork,m,n
      character prefix

      INTEGER NB
      INTEGER ILAENV
      EXTERNAL ILAENV
      INTRINSIC MAX

      NB = ILAENV( 1, prefix // 'GEQRF', ' ', M, N, -1, -1 )

      min_lwork = MAX(1,N)
      max_lwork = MAX(1,N*NB)
      end

      subroutine gqr(min_lwork,max_lwork,prefix,m,n)

      integer min_lwork,max_lwork,m,n
      character prefix

      INTEGER NB
      INTEGER ILAENV
      EXTERNAL ILAENV
      INTRINSIC MAX

      if ((prefix.eq.'d').or.(prefix.eq.'s')
     $     .or.(prefix.eq.'D').or.(prefix.eq.'S')) then
         NB = ILAENV( 1, prefix // 'ORGQR', ' ', M, N, -1, -1 )
      else
         NB = ILAENV( 1, prefix // 'UNGQR', ' ', M, N, -1, -1 )
      endif
      min_lwork = MAX(1,N)
      max_lwork = MAX(1,N*NB)
      end


program f_call_c
    Use Iso_C_Binding

    !dense 2x2 matrix in COO format
    Integer :: n=2, nnz=4, ierr
    Real(C_double) :: x(2)
    Real(C_double) :: y(2)
    Real(C_double) :: val(4)
    Integer(C_int) :: col(4)
    Integer(C_int) :: row(4)

    x(1) = 1.0
    x(2) = 2.0

    ! dammy
    y(1) = 111.0
    y(2) = 111.0

    val(1) = 1.0
    val(2) = 2.0
    val(3) = 3.0
    val(4) = 4.0

    row(1) = 1
    row(2) = 1
    row(3) = 2
    row(4) = 2

    col(1) = 1
    col(2) = 2
    col(3) = 1
    col(4) = 2

    ! SpMV is...
    ! | 1 | 2 | * | 1 | = | 5  |
    ! | 3 | 4 |   | 2 |   | 11 |

!     print *, "Fortran calling C, passing"
!     print *, "i=",i,"x=",x
    ierr = monolish_matvec(n, nnz, row, col, val, x, y)

    print *, "y0=",y(1)
    print *, "y1=",y(2)
end program f_call_c


	! integrates hmf model by rk4 method and finds the variation of temperature and order parameter (magnetization) with energy per particle

	implicit none

	integer, parameter :: mm=100, nn=2*mm
	integer, parameter :: nh=1, iter=5000
	double precision   :: xx(nn), yy(nn), dy(nn)
	double precision   :: tau, dtau, amp, omega, r, phi
	double precision   :: pi, pi2, grnd
	integer            :: i,j,k,l,m,n
	double precision   :: KE, PE, H, U, a
	double precision   :: Uavg(iter), Tavg(iter), Ravg(iter)

	common amp, omega

	pi   = 4.0d0*datan(1.0d0); pi2 = 2.0d0*pi
	tau  = 0.0d0; dtau = 0.01d0

	amp=5.0d0; omega=0.0d0

	call sgrnd(148)

	open (unit=1,file='Khmf_withoutw.dat',status='unknown')

	U = 0.50d0; H = U*mm
	Uavg=0.0d0; Tavg=0.0d0; Ravg=0.0d0

	do j = 1, nh	! history

	do n = 1, mm
	yy(n) = 0.1*(grnd()-0.5d0)
	end do

	PE = 0.0d0
	do m = 2, mm
	do n = 1, mm
	PE = PE + dcos(yy(m)-yy(n))
	end do
	PE=PE+abs(amp*cos(omega*tau))*dcos(yy(1)-yy(n))
	end do
	PE = (1/nn)*(mm**2-PE)

	a = 2.0d0*sqrt((12.0d0/nn)*(H-PE))

	do n = mm+1, nn
        yy(n) = a*(grnd()-0.5d0)
        end do

	do k = 1, iter	! iterations

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)

	yy = xx

	call order_parameter(xx,r,phi)

	KE = 0.0d0
	do n = mm+1, nn
	KE = KE + yy(n)**2
	end do
	KE = KE/2.0d0

	!PE = 0.0d0
	!do n = 1, mm
	!do m = 1, mm
	!PE = PE + dcos(yy(n)-yy(m))
	!end do
	!end do

	PE = 0.0d0
	do m = 2, mm
	do n = 1, mm
	PE = PE + dcos(yy(m)-yy(n))
	end do
	PE=PE+abs(amp*cos(omega*tau))*dcos(yy(1)-yy(n))
	end do
	PE = (1/nn)*(mm**2-PE)

	PE = (1/nn)*(mm**2-PE)

	H = PE + KE

	write(1,'(41(xf12.6))') H/mm, 2*KE/mm, r

	Uavg = Uavg + H/mm
	Tavg = Tavg + 2*KE/mm
	Ravg = Ravg + r

	end do	! iterations

        end do	! history

	!write(1,'(41(xf10.6))') amp, Uavg, Tavg, Ravg

	end program

	! calculates the time derivative

        subroutine derivs(tau,yy,dy)

        integer, parameter :: mm=100, nn=2*mm
	double precision   :: yy(nn), dy(nn)
	double precision   :: pi, tau, dtau
	integer            :: i, j, k, l, m, n
        double precision   :: kk, amp, omega, r, phi

	common amp, omega

	call order_parameter(yy,r,phi)

	kk = abs(amp*dcos(omega*tau))

        do i = 1, mm
        dy(i) = yy(mm+i)
        end do

	do i = mm+2, nn
        dy(i) = r*dsin(phi-yy(i-mm))
	dy(mm+1) = kk*r*dsin(phi-yy(i-mm))
        end do

        return
        end subroutine

	! finds the magnitude and phase of the order parameter

	subroutine order_parameter(theta,r,phi)

        integer, parameter :: mm=100, nn=2*mm
        double precision   :: theta(nn)
        double precision   :: r, phi, real_sum, imag_sum

        real_sum = 0.0d0
        imag_sum = 0.0d0

        do j=1,mm
        real_sum = real_sum + dcos(theta(j))
        imag_sum = imag_sum + dsin(theta(j))
        enddo

        real_sum = real_sum/mm
        imag_sum = imag_sum/mm
        r = dsqrt((real_sum)**2 + (imag_sum)**2)
        phi = dacos(real_sum/r)

        return
        end

	SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)

	INTEGER n,NMAX
	REAL*8 h,x,dydx(n),y(n),yout(n)
	EXTERNAL derivs
	PARAMETER (NMAX=200)
	INTEGER i
	REAL*8 h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)

	hh=h*0.5
	h6=h/6.
	xh=x+hh

	do i=1,n
        yt(i)=y(i)+hh*dydx(i)
	end do

	call derivs(xh,yt,dyt)
	do i=1,n
        yt(i)=y(i)+hh*dyt(i)
	end do

	call derivs(xh,yt,dym)
	do i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
	end do

	call derivs(x+h,yt,dyt)
	do i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
	end do

	return
	END

	include 'mt.f'


program outcomes

  integer, dimension(1:10) :: deck
  integer :: d,n,p
  integer, external :: partitions

  deck = (/ (4, i = 1,10) /)
  deck(10) = 16

  d = 0

  do i = 1, 10
     ! Dealer showing
     deck(i) = deck(i)-1

     p = 0
     do j = 1, 10
        deck(j) = deck(j)-1
        n = partitions(deck, j)
        deck(j) = deck(j)+1
        p = p+n
     end do

     print *,"Dealer showing ",i," partitions =",p
     d = d+p
     deck(i) = deck(i)+1
  end do

  print *,"Total partitions =",d

end program outcomes


*DECK CSIDI
      SUBROUTINE CSIDI (A, LDA, N, KPVT, DET, WORK, JOB)
C***BEGIN PROLOGUE  CSIDI
C***PURPOSE  Compute the determinant and inverse of a complex symmetric
C            matrix using the factors from CSIFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C1, D3C1
C***TYPE      COMPLEX (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             SYMMETRIC
C***AUTHOR  Bunch, J., (UCSD)
C***DESCRIPTION
C
C     CSIDI computes the determinant and inverse
C     of a complex symmetric matrix using the factors from CSIFA.
C
C     On Entry
C
C        A       COMPLEX(LDA,N)
C                the output from CSIFA.
C
C        LDA     INTEGER
C                the leading dimension of the array A .
C
C        N       INTEGER
C                the order of the matrix A .
C
C        KVPT    INTEGER(N)
C                the pivot vector from CSIFA.
C
C        WORK    COMPLEX(N)
C                work vector.  Contents destroyed.
C
C        JOB     INTEGER
C                JOB has the decimal expansion  AB  where
C                   If  B .NE. 0, the inverse is computed,
C                   If  A .NE. 0, the determinant is computed,
C
C                For example, JOB = 11  gives both.
C
C     On Return
C
C        Variables not requested by JOB are not used.
C
C        A      contains the upper triangle of the inverse of
C               the original matrix.  The strict lower triangle
C               is never referenced.
C
C        DET    COMPLEX(2)
C               determinant of original matrix.
C               Determinant = DET(1) * 10.0**DET(2)
C               with 1.0 .LE. ABS(DET(1)) .LT. 10.0
C               or DET(1) = 0.0.
C
C     Error Condition
C
C        A division by zero may occur if the inverse is requested
C        and  CSICO  has set RCOND .EQ. 0.0
C        or  CSIFA  has set  INFO .NE. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CCOPY, CDOTU, CSWAP
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Corrected category and modified routine equivalence
C           list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CSIDI
      INTEGER LDA,N,JOB
      COMPLEX A(LDA,*),DET(2),WORK(*)
      INTEGER KPVT(*)
C
      COMPLEX AK,AKP1,AKKP1,CDOTU,D,T,TEMP
      REAL TEN
      INTEGER J,JB,K,KM1,KS,KSTEP
      LOGICAL NOINV,NODET
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C***FIRST EXECUTABLE STATEMENT  CSIDI
      NOINV = MOD(JOB,10) .EQ. 0
      NODET = MOD(JOB,100)/10 .EQ. 0
C
      IF (NODET) GO TO 100
         DET(1) = (1.0E0,0.0E0)
         DET(2) = (0.0E0,0.0E0)
         TEN = 10.0E0
         T = (0.0E0,0.0E0)
         DO 90 K = 1, N
            D = A(K,K)
C
C           CHECK IF 1 BY 1
C
            IF (KPVT(K) .GT. 0) GO TO 30
C
C              2 BY 2 BLOCK
C              USE DET (D  T)  =  (D/T * C - T) * T
C                      (T  C)
C              TO AVOID UNDERFLOW/OVERFLOW TROUBLES.
C              TAKE TWO PASSES THROUGH SCALING.  USE  T  FOR FLAG.
C
               IF (CABS1(T) .NE. 0.0E0) GO TO 10
                  T = A(K,K+1)
                  D = (D/T)*A(K+1,K+1) - T
               GO TO 20
   10          CONTINUE
                  D = T
                  T = (0.0E0,0.0E0)
   20          CONTINUE
   30       CONTINUE
C
            DET(1) = D*DET(1)
            IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 80
   40          IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 50
                  DET(1) = CMPLX(TEN,0.0E0)*DET(1)
                  DET(2) = DET(2) - (1.0E0,0.0E0)
               GO TO 40
   50          CONTINUE
   60          IF (CABS1(DET(1)) .LT. TEN) GO TO 70
                  DET(1) = DET(1)/CMPLX(TEN,0.0E0)
                  DET(2) = DET(2) + (1.0E0,0.0E0)
               GO TO 60
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
C
C     COMPUTE INVERSE(A)
C
      IF (NOINV) GO TO 230
         K = 1
  110    IF (K .GT. N) GO TO 220
            KM1 = K - 1
            IF (KPVT(K) .LT. 0) GO TO 140
C
C              1 BY 1
C
               A(K,K) = (1.0E0,0.0E0)/A(K,K)
               IF (KM1 .LT. 1) GO TO 130
                  CALL CCOPY(KM1,A(1,K),1,WORK,1)
                  DO 120 J = 1, KM1
                     A(J,K) = CDOTU(J,A(1,J),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  120             CONTINUE
                  A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1)
  130          CONTINUE
               KSTEP = 1
            GO TO 180
  140       CONTINUE
C
C              2 BY 2
C
               T = A(K,K+1)
               AK = A(K,K)/T
               AKP1 = A(K+1,K+1)/T
               AKKP1 = A(K,K+1)/T
               D = T*(AK*AKP1 - (1.0E0,0.0E0))
               A(K,K) = AKP1/D
               A(K+1,K+1) = AK/D
               A(K,K+1) = -AKKP1/D
               IF (KM1 .LT. 1) GO TO 170
                  CALL CCOPY(KM1,A(1,K+1),1,WORK,1)
                  DO 150 J = 1, KM1
                     A(J,K+1) = CDOTU(J,A(1,J),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K+1),1)
  150             CONTINUE
                  A(K+1,K+1) = A(K+1,K+1)
     1                         + CDOTU(KM1,WORK,1,A(1,K+1),1)
                  A(K,K+1) = A(K,K+1) + CDOTU(KM1,A(1,K),1,A(1,K+1),1)
                  CALL CCOPY(KM1,A(1,K),1,WORK,1)
                  DO 160 J = 1, KM1
                     A(J,K) = CDOTU(J,A(1,J),1,WORK,1)
                     CALL CAXPY(J-1,WORK(J),A(1,J),1,A(1,K),1)
  160             CONTINUE
                  A(K,K) = A(K,K) + CDOTU(KM1,WORK,1,A(1,K),1)
  170          CONTINUE
               KSTEP = 2
  180       CONTINUE
C
C           SWAP
C
            KS = ABS(KPVT(K))
            IF (KS .EQ. K) GO TO 210
               CALL CSWAP(KS,A(1,KS),1,A(1,K),1)
               DO 190 JB = KS, K
                  J = K + KS - JB
                  TEMP = A(J,K)
                  A(J,K) = A(KS,J)
                  A(KS,J) = TEMP
  190          CONTINUE
               IF (KSTEP .EQ. 1) GO TO 200
                  TEMP = A(KS,K+1)
                  A(KS,K+1) = A(K,K+1)
                  A(K,K+1) = TEMP
  200          CONTINUE
  210       CONTINUE
            K = K + KSTEP
         GO TO 110
  220    CONTINUE
  230 CONTINUE
      RETURN
      END


subroutine nrmaxl(rfin,maxk,rinit,kopt,v_dic)
  implicit none
  logical            :: kNN
  integer,intent(in) :: maxk
  real*8,intent(in)  :: rinit
  integer,intent(in) :: kopt
  real*8,intent(in)  :: v_dic(maxk)
  !real*8,intent(out)  :: vi(maxk)
  real*8,intent(out)  :: rfin
  real*8 :: b,L0,a,stepmax,ga,gb,Cov2(2,2),Covinv2(2,2)
  real*8 :: jf,t,s,tt,func,sigma,sa,sb,vi(maxk)
  integer :: j,niter
  !write (6,*) maxk,rinit,kopt,(v_dic(j),j=1,kopt)
  !Integer, Parameter :: kdp = selected_real_kind(15)
  !real (kind=kdp) :: dimset                    ! dimension in which is embedded the dataset (real)
  !real (kind=kdp), Parameter :: nearzero = tiny(dimset)  ! Minimum positive value
  b=rinit
  L0=0.
  a=0.
  stepmax=0.1*abs(b)
  gb=float(kopt)
  ga=float(kopt+1)*float(kopt)/2.
  Cov2(1,1)=0. !gbb
  Cov2(1,2)=0. !gab
  Cov2(2,2)=0. !gaa
  kNN=.false.
  vi(1)=v_dic(1)
  do j=2,kopt
    vi(j)=v_dic(j)-v_dic(j-1)
    if ((vi(j)<1D-300).and.(.not.kNN)) then
       !write (6,*) rinit,kopt,kNN,vi(j),v_dic(j),v_dic(j-1),j
       kNN=.true.
    endif
  enddo
  if (.not.kNN) then
    do j=1,kopt
      jf=float(j)
      t=b+a*jf
      s=exp(t)
      tt=vi(j)*s
      L0=L0+t-tt
      gb=gb-tt
      ga=ga-jf*tt
      Cov2(1,1)=Cov2(1,1)-tt
      Cov2(1,2)=Cov2(1,2)-jf*tt
      Cov2(2,2)=Cov2(2,2)-jf*jf*tt
    enddo
    Cov2(2,1)=Cov2(1,2)
    Covinv2=matinv2(Cov2)
    func=100.
    niter=0
    do while ((func>1D-3).and.(niter.lt.1000))
      sb=(Covinv2(1,1)*gb+Covinv2(1,2)*ga)
      sa=(Covinv2(2,1)*gb+Covinv2(2,2)*ga)
      niter=niter+1
      sigma=0.1
      if (abs(sigma*sb).gt.stepmax) then
        sigma=abs(stepmax/sb)
      endif
      b=b-sigma*sb
      a=a-sigma*sa
      L0=0.
      gb=float(kopt)
      ga=float(kopt+1)*float(kopt)/2.
      Cov2(1,1)=0. !gbb
      Cov2(1,2)=0. !gab
      Cov2(2,2)=0. !gaa
      do j=1,kopt
        jf=float(j)
        t=b+a*jf
        s=exp(t)
        tt=vi(j)*s
        L0=L0+t-tt
        gb=gb-tt
        ga=ga-jf*tt
        Cov2(1,1)=Cov2(1,1)-tt
        Cov2(1,2)=Cov2(1,2)-jf*tt
        Cov2(2,2)=Cov2(2,2)-jf*jf*tt
      enddo
      Cov2(2,1)=Cov2(1,2)
      Covinv2=matinv2(Cov2)
      if ((abs(a).le.tiny(a)).or.(abs(b).le.tiny(b))) then
        func=max(gb,ga)
      else
        func=max(abs(gb/b),abs(ga/a))
      endif
    enddo
  endif
  Cov2(:,:)=-Cov2(:,:)
  Covinv2=matinv2(Cov2)
  rfin=b
contains
  pure function matinv2(A) result(B)
!! Performs a direct calculation of the inverse of a 2×2 matrix.
    real*8, intent(in) :: A(2,2)   !! Matrix
    real*8             :: B(2,2)   !! Inverse matrix
    real*8             :: detinv
    detinv = 1./(A(1,1)*A(2,2) - A(1,2)*A(2,1))
    B(1,1) = +detinv * A(2,2)
    B(2,1) = -detinv * A(2,1)
    B(1,2) = -detinv * A(1,2)
    B(2,2) = +detinv * A(1,1)
  end function
end subroutine NRmaxL


program web
  integer :: i, k
  real, dimension(10, 10) :: a, b
  real :: x, y
  integer :: n, m

    do i = 1, n
    do j = 1, m
      x = a(i, j-1) + a(i, j+1) + a(i, j)
      y = a(i+1, j-1) + a(i+1, j+1) + a(i+1, j)
      != stencil readOnce, forward(depth=1, dim=1)*centered(depth=1, dim=2) :: a
      b(i, j) = x + y
    end do
  end do
  end program web


!*==sgeesx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGEESX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
!                          WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
!                          IWORK, LIWORK, BWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          JOBVS, SENSE, SORT
!       INTEGER            INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
!       REAL               RCONDE, RCONDV
!       ..
!       .. Array Arguments ..
!       LOGICAL            BWORK( * )
!       INTEGER            IWORK( * )
!       REAL               A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
!      $                   WR( * )
!       ..
!       .. Function Arguments ..
!       LOGICAL            SELECT
!       EXTERNAL           SELECT
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGEESX computes for an N-by-N real nonsymmetric matrix A, the
!> eigenvalues, the real Schur form T, and, optionally, the matrix of
!> Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).
!>
!> Optionally, it also orders the eigenvalues on the diagonal of the
!> real Schur form so that selected eigenvalues are at the top left;
!> computes a reciprocal condition number for the average of the
!> selected eigenvalues (RCONDE); and computes a reciprocal condition
!> number for the right invariant subspace corresponding to the
!> selected eigenvalues (RCONDV).  The leading columns of Z form an
!> orthonormal basis for this invariant subspace.
!>
!> For further explanation of the reciprocal condition numbers RCONDE
!> and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
!> these quantities are called s and sep respectively).
!>
!> A real matrix is in real Schur form if it is upper quasi-triangular
!> with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
!> the form
!>           [  a  b  ]
!>           [  c  a  ]
!>
!> where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] JOBVS
!> \verbatim
!>          JOBVS is CHARACTER*1
!>          = 'N': Schur vectors are not computed;
!>          = 'V': Schur vectors are computed.
!> \endverbatim
!>
!> \param[in] SORT
!> \verbatim
!>          SORT is CHARACTER*1
!>          Specifies whether or not to order the eigenvalues on the
!>          diagonal of the Schur form.
!>          = 'N': Eigenvalues are not ordered;
!>          = 'S': Eigenvalues are ordered (see SELECT).
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is a LOGICAL FUNCTION of two REAL arguments
!>          SELECT must be declared EXTERNAL in the calling subroutine.
!>          If SORT = 'S', SELECT is used to select eigenvalues to sort
!>          to the top left of the Schur form.
!>          If SORT = 'N', SELECT is not referenced.
!>          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
!>          SELECT(WR(j),WI(j)) is true; i.e., if either one of a
!>          complex conjugate pair of eigenvalues is selected, then both
!>          are.  Note that a selected complex eigenvalue may no longer
!>          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
!>          ordering may change the value of complex eigenvalues
!>          (especially if the eigenvalue is ill-conditioned); in this
!>          case INFO may be set to N+3 (see INFO below).
!> \endverbatim
!>
!> \param[in] SENSE
!> \verbatim
!>          SENSE is CHARACTER*1
!>          Determines which reciprocal condition numbers are computed.
!>          = 'N': None are computed;
!>          = 'E': Computed for average of selected eigenvalues only;
!>          = 'V': Computed for selected right invariant subspace only;
!>          = 'B': Computed for both.
!>          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA, N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A is overwritten by its real Schur form T.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] SDIM
!> \verbatim
!>          SDIM is INTEGER
!>          If SORT = 'N', SDIM = 0.
!>          If SORT = 'S', SDIM = number of eigenvalues (after sorting)
!>                         for which SELECT is true. (Complex conjugate
!>                         pairs for which SELECT is true for either
!>                         eigenvalue count as 2.)
!> \endverbatim
!>
!> \param[out] WR
!> \verbatim
!>          WR is REAL array, dimension (N)
!> \endverbatim
!>
!> \param[out] WI
!> \verbatim
!>          WI is REAL array, dimension (N)
!>          WR and WI contain the real and imaginary parts, respectively,
!>          of the computed eigenvalues, in the same order that they
!>          appear on the diagonal of the output Schur form T.  Complex
!>          conjugate pairs of eigenvalues appear consecutively with the
!>          eigenvalue having the positive imaginary part first.
!> \endverbatim
!>
!> \param[out] VS
!> \verbatim
!>          VS is REAL array, dimension (LDVS,N)
!>          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
!>          vectors.
!>          If JOBVS = 'N', VS is not referenced.
!> \endverbatim
!>
!> \param[in] LDVS
!> \verbatim
!>          LDVS is INTEGER
!>          The leading dimension of the array VS.  LDVS >= 1, and if
!>          JOBVS = 'V', LDVS >= N.
!> \endverbatim
!>
!> \param[out] RCONDE
!> \verbatim
!>          RCONDE is REAL
!>          If SENSE = 'E' or 'B', RCONDE contains the reciprocal
!>          condition number for the average of the selected eigenvalues.
!>          Not referenced if SENSE = 'N' or 'V'.
!> \endverbatim
!>
!> \param[out] RCONDV
!> \verbatim
!>          RCONDV is REAL
!>          If SENSE = 'V' or 'B', RCONDV contains the reciprocal
!>          condition number for the selected right invariant subspace.
!>          Not referenced if SENSE = 'N' or 'E'.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.  LWORK >= max(1,3*N).
!>          Also, if SENSE = 'E' or 'V' or 'B',
!>          LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
!>          selected eigenvalues computed by this routine.  Note that
!>          N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
!>          returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
!>          'B' this may not be large enough.
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates upper bounds on the optimal sizes of the
!>          arrays WORK and IWORK, returns these values as the first
!>          entries of the WORK and IWORK arrays, and no error messages
!>          related to LWORK or LIWORK are issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (MAX(1,LIWORK))
!>          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
!> \endverbatim
!>
!> \param[in] LIWORK
!> \verbatim
!>          LIWORK is INTEGER
!>          The dimension of the array IWORK.
!>          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
!>          Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
!>          only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
!>          may not be large enough.
!>
!>          If LIWORK = -1, then a workspace query is assumed; the
!>          routine only calculates upper bounds on the optimal sizes of
!>          the arrays WORK and IWORK, returns these values as the first
!>          entries of the WORK and IWORK arrays, and no error messages
!>          related to LWORK or LIWORK are issued by XERBLA.
!> \endverbatim
!>
!> \param[out] BWORK
!> \verbatim
!>          BWORK is LOGICAL array, dimension (N)
!>          Not referenced if SORT = 'N'.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value.
!>          > 0: if INFO = i, and i is
!>             <= N: the QR algorithm failed to compute all the
!>                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
!>                   contain those eigenvalues which have converged; if
!>                   JOBVS = 'V', VS contains the transformation which
!>                   reduces A to its partially converged Schur form.
!>             = N+1: the eigenvalues could not be reordered because some
!>                   eigenvalues were too close to separate (the problem
!>                   is very ill-conditioned);
!>             = N+2: after reordering, roundoff changed values of some
!>                   complex eigenvalues so that leading eigenvalues in
!>                   the Schur form no longer satisfy SELECT=.TRUE.  This
!>                   could also be caused by underflow due to scaling.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup realGEeigen
!
!  =====================================================================
      SUBROUTINE SGEESX(Jobvs,Sort,SELECT,Sense,N,A,Lda,Sdim,Wr,Wi,Vs,  &
     &                  Ldvs,Rconde,Rcondv,Work,Lwork,Iwork,Liwork,     &
     &                  Bwork,Info)
      IMPLICIT NONE
!*--SGEESX285
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Jobvs , Sense , Sort
      INTEGER Info , Lda , Ldvs , Liwork , Lwork , N , Sdim
      REAL Rconde , Rcondv
!     ..
!     .. Array Arguments ..
      LOGICAL Bwork(*)
      INTEGER Iwork(*)
      REAL A(Lda,*) , Vs(Ldvs,*) , Wi(*) , Work(*) , Wr(*)
!     ..
!     .. Function Arguments ..
      LOGICAL SELECT
      EXTERNAL SELECT
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      LOGICAL cursl , lastsl , lquery , lst2sl , scalea , wantsb ,      &
     &        wantse , wantsn , wantst , wantsv , wantvs
      INTEGER hswork , i , i1 , i2 , ibal , icond , ierr , ieval , ihi ,&
     &        ilo , inxt , ip , itau , iwrk , lwrk , liwrk , maxwrk ,   &
     &        minwrk
      REAL anrm , bignum , cscale , eps , smlnum
!     ..
!     .. Local Arrays ..
      REAL dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL SCOPY , SGEBAK , SGEBAL , SGEHRD , SHSEQR , SLABAD ,     &
     &         SLACPY , SLASCL , SORGHR , SSWAP , STRSEN , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL SLAMCH , SLANGE
      EXTERNAL LSAME , ILAENV , SLAMCH , SLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      wantvs = LSAME(Jobvs,'V')
      wantst = LSAME(Sort,'S')
      wantsn = LSAME(Sense,'N')
      wantse = LSAME(Sense,'E')
      wantsv = LSAME(Sense,'V')
      wantsb = LSAME(Sense,'B')
      lquery = (Lwork==-1 .OR. Liwork==-1)
!
      IF ( (.NOT.wantvs) .AND. (.NOT.LSAME(Jobvs,'N')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantst) .AND. (.NOT.LSAME(Sort,'N')) ) THEN
         Info = -2
      ELSEIF ( .NOT.(wantsn .OR. wantse .OR. wantsv .OR. wantsb) .OR.   &
     &         (.NOT.wantst .AND. .NOT.wantsn) ) THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvs<1 .OR. (wantvs .AND. Ldvs<N) ) THEN
         Info = -12
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "RWorkspace:" describe the
!       minimal amount of real workspace needed at that point in the
!       code, as well as the preferred amount for good performance.
!       IWorkspace refers to integer workspace.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by SHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.
!       If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
!       depends on SDIM, which is computed by the routine STRSEN later
!       in the code.)
!
      IF ( Info==0 ) THEN
         liwrk = 1
         IF ( N==0 ) THEN
            minwrk = 1
            lwrk = 1
         ELSE
            maxwrk = 2*N + N*ILAENV(1,'SGEHRD',' ',N,1,N,0)
            minwrk = 3*N
!
            CALL SHSEQR('S',Jobvs,N,1,N,A,Lda,Wr,Wi,Vs,Ldvs,Work,-1,    &
     &                  ieval)
            hswork = Work(1)
!
            IF ( .NOT.wantvs ) THEN
               maxwrk = MAX(maxwrk,N+hswork)
            ELSE
               maxwrk = MAX(maxwrk,2*N+(N-1)                            &
     &                  *ILAENV(1,'SORGHR',' ',N,1,N,-1))
               maxwrk = MAX(maxwrk,N+hswork)
            ENDIF
            lwrk = maxwrk
            IF ( .NOT.wantsn ) lwrk = MAX(lwrk,N+(N*N)/2)
            IF ( wantsv .OR. wantsb ) liwrk = (N*N)/4
         ENDIF
         Iwork(1) = liwrk
         Work(1) = lwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) THEN
            Info = -16
         ELSEIF ( Liwork<1 .AND. .NOT.lquery ) THEN
            Info = -18
         ENDIF
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGEESX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) THEN
         Sdim = 0
         RETURN
      ENDIF
!
!     Get machine constants
!
      eps = SLAMCH('P')
      smlnum = SLAMCH('S')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = SLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL SLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Permute the matrix to make it more nearly triangular
!     (RWorkspace: need N)
!
      ibal = 1
      CALL SGEBAL('P',N,A,Lda,ilo,ihi,Work(ibal),ierr)
!
!     Reduce to upper Hessenberg form
!     (RWorkspace: need 3*N, prefer 2*N+N*NB)
!
      itau = N + ibal
      iwrk = N + itau
      CALL SGEHRD(N,ilo,ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvs ) THEN
!
!        Copy Householder vectors to VS
!
         CALL SLACPY('L',N,N,A,Lda,Vs,Ldvs)
!
!        Generate orthogonal matrix in VS
!        (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!
         CALL SORGHR(N,ilo,ihi,Vs,Ldvs,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
      ENDIF
!
      Sdim = 0
!
!     Perform QR iteration, accumulating Schur vectors in VS if desired
!     (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
!
      iwrk = itau
      CALL SHSEQR('S',Jobvs,N,ilo,ihi,A,Lda,Wr,Wi,Vs,Ldvs,Work(iwrk),   &
     &            Lwork-iwrk+1,ieval)
      IF ( ieval>0 ) Info = ieval
!
!     Sort eigenvalues if desired
!
      IF ( wantst .AND. Info==0 ) THEN
         IF ( scalea ) THEN
            CALL SLASCL('G',0,0,cscale,anrm,N,1,Wr,N,ierr)
            CALL SLASCL('G',0,0,cscale,anrm,N,1,Wi,N,ierr)
         ENDIF
         DO i = 1 , N
            Bwork(i) = SELECT(Wr(i),Wi(i))
         ENDDO
!
!        Reorder eigenvalues, transform Schur vectors, and compute
!        reciprocal condition numbers
!        (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
!                     otherwise, need N )
!        (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
!                     otherwise, need 0 )
!
         CALL STRSEN(Sense,Jobvs,Bwork,N,A,Lda,Vs,Ldvs,Wr,Wi,Sdim,      &
     &               Rconde,Rcondv,Work(iwrk),Lwork-iwrk+1,Iwork,Liwork,&
     &               icond)
         IF ( .NOT.wantsn ) maxwrk = MAX(maxwrk,N+2*Sdim*(N-Sdim))
         IF ( icond==-15 ) THEN
!
!           Not enough real workspace
!
            Info = -16
         ELSEIF ( icond==-17 ) THEN
!
!           Not enough integer workspace
!
            Info = -18
         ELSEIF ( icond>0 ) THEN
!
!           STRSEN failed to reorder or to restore standard Schur form
!
            Info = icond + N
         ENDIF
      ENDIF
!
!
!        Undo balancing
!        (RWorkspace: need N)
!
      IF ( wantvs ) CALL SGEBAK('P','R',N,ilo,ihi,Work(ibal),N,Vs,Ldvs, &
     &                          ierr)
!
      IF ( scalea ) THEN
!
!        Undo scaling for the Schur form of A
!
         CALL SLASCL('H',0,0,cscale,anrm,N,N,A,Lda,ierr)
         CALL SCOPY(N,A,Lda+1,Wr,1)
         IF ( (wantsv .OR. wantsb) .AND. Info==0 ) THEN
            dum(1) = Rcondv
            CALL SLASCL('G',0,0,cscale,anrm,1,1,dum,1,ierr)
            Rcondv = dum(1)
         ENDIF
         IF ( cscale==smlnum ) THEN
!
!           If scaling back towards underflow, adjust WI if an
!           offdiagonal element of a 2-by-2 block in the Schur form
!           underflows.
!
            IF ( ieval>0 ) THEN
               i1 = ieval + 1
               i2 = ihi - 1
               CALL SLASCL('G',0,0,cscale,anrm,ilo-1,1,Wi,N,ierr)
            ELSEIF ( wantst ) THEN
               i1 = 1
               i2 = N - 1
            ELSE
               i1 = ilo
               i2 = ihi - 1
            ENDIF
            inxt = i1 - 1
            DO i = i1 , i2
               IF ( i>=inxt ) THEN
                  IF ( Wi(i)==ZERO ) THEN
                     inxt = i + 1
                  ELSE
                     IF ( A(i+1,i)==ZERO ) THEN
                        Wi(i) = ZERO
                        Wi(i+1) = ZERO
                     ELSEIF ( A(i+1,i)/=ZERO .AND. A(i,i+1)==ZERO ) THEN
                        Wi(i) = ZERO
                        Wi(i+1) = ZERO
                        IF ( i>1 ) CALL SSWAP(i-1,A(1,i),1,A(1,i+1),1)
                        IF ( N>i+1 )                                    &
     &                       CALL SSWAP(N-i-1,A(i,i+2),Lda,A(i+1,i+2),  &
     &                       Lda)
                        IF ( wantvs )                                   &
     &                       CALL SSWAP(N,Vs(1,i),1,Vs(1,i+1),1)
                        A(i,i+1) = A(i+1,i)
                        A(i+1,i) = ZERO
                     ENDIF
                     inxt = i + 2
                  ENDIF
               ENDIF
            ENDDO
         ENDIF
         CALL SLASCL('G',0,0,cscale,anrm,N-ieval,1,Wi(ieval+1),         &
     &               MAX(N-ieval,1),ierr)
      ENDIF
!
      IF ( wantst .AND. Info==0 ) THEN
!
!        Check if reordering successful
!
         lastsl = .TRUE.
         lst2sl = .TRUE.
         Sdim = 0
         ip = 0
         DO i = 1 , N
            cursl = SELECT(Wr(i),Wi(i))
            IF ( Wi(i)==ZERO ) THEN
               IF ( cursl ) Sdim = Sdim + 1
               ip = 0
               IF ( cursl .AND. .NOT.lastsl ) Info = N + 2
            ELSEIF ( ip==1 ) THEN
!
!                 Last eigenvalue of conjugate pair
!
               cursl = cursl .OR. lastsl
               lastsl = cursl
               IF ( cursl ) Sdim = Sdim + 2
               ip = -1
               IF ( cursl .AND. .NOT.lst2sl ) Info = N + 2
            ELSE
!
!                 First eigenvalue of conjugate pair
!
               ip = 1
            ENDIF
            lst2sl = lastsl
            lastsl = cursl
         ENDDO
      ENDIF
!
      Work(1) = maxwrk
      IF ( wantsv .OR. wantsb ) THEN
         Iwork(1) = Sdim*(N-Sdim)
      ELSE
         Iwork(1) = 1
      ENDIF
!
!
!     End of SGEESX
!
      END SUBROUTINE SGEESX


!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Module Functions
  implicit none
contains
!==
  Function cross(a,b) result(c)
    implicit none
    real(8) :: c(1:3)
    real(8), intent(in) :: a(1:3), b(1:3)

    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)
    return
  End Function cross
!==
!==
  Function bandtrace(array) result(trace)
    use Global_Variables, only : NB
    implicit none
    complex(8), intent(in) :: array(1:NB,1:NB)
    complex(8) :: trace
    integer :: ib

    trace = (0.d0,0.d0)
    Do ib = 1,NB
      trace = trace + array(ib,ib)
    End do
    return
  End Function bandtrace
!==
!==
  Function k_vCk(k) result(vCk)
    use Constants
    use Global_Variables, only : NK,acell,NG
    implicit none
    Real(8), intent(in) :: k
    Integer, parameter :: Nx = 100000
    Real(8) :: vCk, kx, dx
    integer ix

    dx = acell/dble(NG)/20.0d0
    vCk = 0.d0
    ix = 0
    Do While ((ix*dx) < (NK*acell))
      vCk = vCk + 0.5d0*(cos(k*(ix*dx))/sqrt((ix*dx)**2+1.0d0**2) + cos(k*((ix+1)*dx))/sqrt(((ix+1)*dx)**2+1.0d0**2))
      ix = ix + 1
    End Do
    vCk = 2.0d0*vCk*dx

    return
  End Function k_vCk
!==
!==
  Function ubk_dns(ubk) result(dns) !########Several 3D array is used as 1D array here for OMP.########
    use Global_Variables, only : NG,NB,NK,occbk
    implicit none
    complex(8), intent(in) :: ubk(1:NG,1:NB,1:NK)
    real(8) :: dns1D(1:NG), dns(1:NG)
    integer :: ib,ik,ig

    dns = 0.d0
    Do ig= 1,NG
      Do ik= 1,NK
        Do ib =1,NB
          dns(ig) = dns(ig) + occbk(ib,ik)*conjg(ubk(ig,ib,ik))*ubk(ig,ib,ik)
        End do
      End do
    End do
    return
  End Function ubk_dns
!==
!==
  Function ubk_Etot(ubk,A) result(Etot)
    use Global_Variables, only : NG,NB,NK,functional
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    real(8), intent(in) :: A
    real(8) :: Etot, Ekin, Eion, EH, Exc, dns(NG)

    dns = ubk_dns(ubk)
    Ekin = ubk_Ekin(ubk,A)
    Eion = dns_Eion(dns)
    EH = dns_EH(dns)
    Select case (trim(functional))
      Case('HF')
        Exc = ubk_Ex(ubk)
    End Select
    Etot = Ekin + Eion + EH + Exc
    return
  End Function ubk_Etot
!==
!==
  Function ubk_Ekin(ubk,A) result(Ekin)
    use Global_Variables, only : NG,NB,NK,dvcell,Gx,kx,occbk, planf, planb
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    real(8), intent(in) :: A
    real(8) :: Ekin
    complex(8) :: work(NG),work2(NG)
    real(8) :: kAx,kA2
    integer :: ib,ik
!FFTW staff
    include 'fftw3.f'

    Ekin = 0.d0
    Do ik= 1,NK
      kAx = kx(ik)+A
      kA2 = kAx**2
      Do ib =1,NB
        Call dfftw_execute_dft(planf,ubk(:,ib,ik),work)
        work(:) = 0.5d0*(Gx(:)**2 + 2.0d0*Gx(:)*kAx + kA2)*work(:)/dble(NG)
        Call dfftw_execute_dft(planb,work,work2(:))
        Ekin = Ekin + occbk(ib,ik)*sum(conjg(ubk(:,ib,ik))*work2(:))*dvcell
      End do
    End do

    return
  End Function ubk_Ekin
!==
!==
  Function dns_Eion(dns) result(Eion)
    use Global_Variables, only : NG,vion,dvcell
    implicit none
    real(8), intent(in) :: dns(NG)
    real(8) :: Eion

    Eion = sum(vion(:)*dns(:))*dvcell

    return
  End Function dns_Eion
!==
!==
  Function dns_EH(dns) result(EH)
    use Global_Variables, only : NG,dvcell
    implicit none
    real(8), intent(in) :: dns(NG)
    real(8) :: vH(NG),EH

    vH = dns_vH(dns)
    EH = 0.5d0*sum(vH(:)*dns(:))*dvcell

    return
  End Function dns_EH
!==
!==
  Function dns_vH(dns) result(vH)
    use Global_Variables, only : NG,vCG, planf,planb
    implicit none
    real(8), intent(in) :: dns(1:NG)
    real(8) :: vH(1:NG)
    complex(8) :: work1(1:NG),work2(1:NG)
!FFTW staff
    include 'fftw3.f'

    work1 = dns
    Call dfftw_execute_dft(planf,work1,work2)
    work2 = vCG*work2
    Call dfftw_execute_dft(planb,work2,work1)
    vH = dble(work1)/dble(NG)
    return
  End Function dns_vH
!==
!==
  Function ubk_Ex(ubk) result(Ex)
    use Global_Variables, only : NG,NB,NK, NBocc, occbk, dvcell
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    complex(8) :: vFubk(NG,NB,NK)
    real(8) :: Ex
    integer :: ib,ik

    vFubk = ubkwbk_vFwbk(ubk,ubk)
    Ex = 0.d0
    Do ik = 1,NK
      Do ib = 1,NBocc
        Ex = Ex + occbk(ib,ik)*sum(conjg(ubk(:,ib,ik))*vFubk(:,ib,ik))*dvcell
      End Do
    End Do
    Ex = 0.5d0*Ex

    return
  End Function ubk_Ex
!==
!==
!Hamiltonian operation to wbk with given ubk
  Function ubkwbk_hwbk(ubk,wbk,A) result(hwbk)
    use Global_Variables, only : NG,NB,NK,functional,vion
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK), wbk(NG,NB,NK)
    real(8), intent(in) :: A
    complex(8) :: hwbk(NG,NB,NK)
    real(8) :: vH(NG),vxc(NG),dns(NG)
    integer :: ib,ik

    hwbk = ubk_tubk(wbk,A)
    dns = ubk_dns(ubk)
    vH = dns_vH(dns)
    Do ik = 1,NK
      Do ib = 1,NB
        hwbk(:,ib,ik) = hwbk(:,ib,ik) + (vH(:)+vion(:))*wbk(:,ib,ik)
      End Do
    End Do
    Select case (trim(functional))
      Case('HF')
        hwbk = hwbk + ubkwbk_vFwbk(ubk,wbk)
    End Select
    return
  End Function ubkwbk_hwbk
!==
!==
  Function ubk_tubk(ubk,A) result(tubk)
    use Global_Variables, only : NG, NB, NK, Gx, kx, planf,planb
    implicit none
    complex(8), intent(in) :: ubk(1:NG,1:NB,1:NK)
    real(8), intent(in) :: A
    complex(8) :: tubk(1:NG,1:NB,1:NK)
    complex(8) :: work(1:NG)
    real(8) :: kAx,kA2
    integer :: ib,ik
!FFTW staff
    include 'fftw3.f'

    Do ik= 1,NK
      kAx = kx(ik)+A
      kA2 = kAx**2
      Do ib =1,NB
        Call dfftw_execute_dft(planf,ubk(:,ib,ik),work)
        work(:) = 0.5d0*(Gx(:)**2 + 2.d0*Gx(:)*kAx + kA2)*work(:)/dble(NG)
        Call dfftw_execute_dft(planb,work,tubk(:,ib,ik))
      End do
    End do
    return
  End Function ubk_tubk
!==
!==
  Function ubkwbk_vFwbk(ubk,wbk) result(vFwbk)
    use Global_Variables, only : NG, NB,NBocc, NK,occbk, NKKs,NKKe,ikrtable,ikctable,vCGkk, planf,planb &
         , MPI_DOUBLE_COMPLEX, MPI_SUM, MPI_COMM_WORLD,ierr, vcell
    implicit none
    complex(8), intent(in) :: ubk(1:NG,1:NB,1:NK), wbk(1:NG,1:NB,1:NK)
    complex(8) :: vFwbk(1:NG,1:NB,1:NK),vFwbk_l(1:NG,1:NB,1:NK)
    complex(8) :: pairrho (NG),pairrhoG(NG), VF(1:NG)
    integer :: ibr,ibc,ikk

    vFwbk_l(:,:,:) = 0.d0
    Do ikk = NKKs,NKKe
      Do ibr = 1,NB
        Do ibc = 1,NBocc
          pairrho(:) = wbk(:,ibr,ikrtable(ikk))*conjg(ubk(:,ibc,ikctable(ikk)))/dble(NK)
          Call dfftw_execute_dft(planf, pairrho, pairrhoG)
          pairrhoG(:) = -vCGkk(:,ikk)*pairrhoG(:)/dble(NG)
          Call dfftw_execute_dft(planb, pairrhoG, VF)
          vFwbk_l(:,ibr,ikrtable(ikk)) = vFwbk_l(:,ibr,ikrtable(ikk)) + VF(:)*ubk(:,ibc,ikctable(ikk))
        End Do
      End Do
    End Do
    Call MPI_ALLREDUCE(vFwbk_l,vFwbk,NG*NB*NK,MPI_DOUBLE_COMPLEX,MPI_SUM,MPI_COMM_WORLD,ierr)

    return
  End Function ubkwbk_vFwbk
!==
!==
!Energy computation w.r.t. each components
  Function ubk_Ecomps(ubk,A) result(Ecomps)
    use Global_Variables, only : NG,NB,NK,functional
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    real(8), intent(in) :: A
    real(8) :: Ecomps(4), Ekin, Epsl, Epsnl, EH, Exc, Eion, Etot, dns(NG)

    dns = ubk_dns(ubk)
    Ekin = ubk_Ekin(ubk,A)
    Eion = dns_Eion(dns)
    EH = dns_EH(dns)
    Select case (trim(functional))
      Case('HF')
        Exc = ubk_Ex(ubk)
    End Select
    Etot = Ekin + Eion + EH + Exc
    Ecomps(1) = Ekin
    Ecomps(2) = Eion
    Ecomps(3) = EH
    Ecomps(4) = Exc
    return
  End Function ubk_Ecomps
!==
!==
  Function ubk_Je(ubk,A) result(Je)
    use Constants
    use Global_Variables, only : NG, NB,NK, dvcell,vcell, Gx,kx, occbk, planf, planb
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    real(8), intent(in) :: A
    complex(8) :: JpkA
    complex(8) :: JpkAx
    real(8) :: Je
    complex(8) :: work1(NG),work2(NG)
    real(8) :: GkAx(NG)
    integer :: ib,ik
!FFTW staff
    include 'fftw3.f'

    JpkAx = 0.d0
    Do ik = 1,NK
      GkAx(:) = Gx(:) + kx(ik) + A
      Do ib = 1,NB
        Call dfftw_execute_dft(planf,ubk(:,ib,ik),work1)
        work1 = work1/dble(NG)
        Call dfftw_execute_dft(planb,GkAx(:)*work1(:),work2)
        JpkAx = JpkAx + occbk(ib,ik)*sum(conjg(ubk(:,ib,ik))*work2(:))
      End do
    End do
    JpkA = JpkAx*dvcell/vcell

    Je = -real(JpkA)
    return
  End Function ubk_Je
!==
!==
  Function ubk_epsbk(ubk) result(epsbk)
    use Global_Variables, only : NG,NB,NK,dvcell
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    complex(8) :: hubk(NG,NB,NK)
    real(8) :: epsbk(NB,NK), A0=0.d0
    integer :: ib,ik

    hubk = ubkwbk_hwbk(ubk,ubk,A0)
    Do ik = 1,NK
      Do ib = 1,NB
        epsbk(ib,ik) = real(sum(conjg(ubk(:,ib,ik))*hubk(:,ib,ik)))*dvcell
      End Do
    End Do

    return
  End Function ubk_epsbk
!==
!==
  Function ubk_epserrorbk(ubk) result(epserrorbk)
    use Global_Variables, only : NG,NB,NK,dvcell
    implicit none
    complex(8), intent(in) :: ubk(NG,NB,NK)
    complex(8) :: hubk(NG,NB,NK)
    real(8) :: epsbk(NB,NK),epserrorbk(NB,NK), A0=0.d0
    integer :: ib,ik

    hubk = ubkwbk_hwbk(ubk,ubk,A0)
    Do ik = 1,NK
      Do ib = 1,NB
        epsbk(ib,ik) = real(sum(conjg(ubk(:,ib,ik))*hubk(:,ib,ik)))*dvcell
        hubk(:,ib,ik) = hubk(:,ib,ik) - epsbk(ib,ik)*ubk(:,ib,ik)
        epserrorbk(ib,ik) = sqrt(sum(abs(hubk(:,ib,ik)))*dvcell)
      End Do
    End Do

    return
  End Function ubk_epserrorbk
!==
End Module Functions
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130


SUBROUTINE mgo_coord_fb
!======================================
! MgO Polynomial CNi
!======================================
! Calculating the analytic coordination number for MgO
! Make use of the mg_coord subroutine to use the Fermi CNi
!======================================
 USE PARACLUSTER
 USE CLUSTER
 USE POTENTIAL
 USE ENFORCE
 USE DISTANCE
 USE SUBSTRATE

 IMPLICIT NONE

 INTEGER               :: i, j, k
 REAL      :: comfactor, gamma_sub
 REAL, ALLOCATABLE	   :: dij(:,:), df_dx(:,:), df_dy(:,:), df_dz(:,:)

IF (ipas==1) WRITE(*,*) "mgo_coord:> first calculation of CN for MgO substrate"
ALLOCATE(dij(natom,natom), df_dx(natom,natom),df_dy(natom,natom),df_dz(natom,natom))
dij(:,:) =0.d0
df_dx(:,:) = 0.d0
df_dy(:,:) = 0.d0
df_dz(:,:) = 0.d0
!coordination number using a smooth Fermi function as
!CN(i) = sum_{j\=i} 1 / [1+exp^alpha(rij/rc-1)]
!beta_sub = alpha_sub/ (rc_sub/aretebim)
!cn(i) = sum_{j/=i} 1 / 1+gamma_sub
!
!$OMP PARALLEL DEFAULT(SHARED)
!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   DO i = 1, natom-1
      DO j = i+1, natom
         ! alpha/rc*r(i,j) -alpha
         dij(j,i) = (beta_sub * pair_dist(j,i) ) - alpha_sub
      END DO
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! Elements on the diagonal
   DO i = 1, natom
      mgo_s(i,i) = 0.d0
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,gamma_sub), SCHEDULE(DYNAMIC,20)
   DO i = 1, natom-1
      DO j = i+1, natom

            gamma_sub = exp(dij(j,i))

            ! The sum of these s(i,j) is the analytic metallic coord no.
            mgo_s(j,i) = 1.d0/(1.d0 + gamma_sub)
            mgo_s(i,j) = mgo_s(j,i)

            ! Derivative of s w.r.t r(i,j)
            ! Use beta_sub to have aretebim as units
            mgo_dS(j,i) = -beta_sub * gamma_sub / (gamma_sub+1)**2
            mgo_dS(i,j) = mgo_dS(j,i)
			!
      END DO ! on j
   END DO ! on i
!$OMP END DO

!$OMP DO PRIVATE(i), SCHEDULE(STATIC)
   ! LP: Calculating the sum of s(i,j), which is mgo_CN(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   DO i = 1, natom
        mgo_cn(i) = SUM(mgo_s(1:natom,i))
		write(898,*) 'mgo_coord:> metallic coord', i, mgo_cn(i)
   END DO
!$OMP END DO

!$OMP DO PRIVATE(i,j,comfactor), SCHEDULE(STATIC)
   !-------------------------------------------------------------------------
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   ! dcn(i)_dx(k)=-sum_{j/=k} beta_sub * gamma_sub /(1 + gamma_sub)^2 xij/rij
   !  			+ beta_sub * gamma_sub /(1+gamma_sub)^2 * xij/rij
   ! forza su atom k due to the coordination of atom i
   ! mgo_dcn(i)_dx(k) = [sum_{j/=k} mgo_dS(k,j) * xkj/rkj] - mgo_dS(i,k)*xik/rik
   DO k = 1, natom    !force over kth-atom due to coordination of atom i
      DO j = 1, natom
         IF (j .NE. k) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            comfactor  = mgo_dS(k,j)/ pair_dist(k,j)
            df_dx(k,j) = comfactor * xyz_dist(1,j,k) ! order of indexes depends on the definition of xyz_dist = x(k) - x(j)
            df_dy(k,j) = comfactor * xyz_dist(2,j,k) ! order of indexes depends on the definition of xyz_dist
            df_dz(k,j) = comfactor * xyz_dist(3,j,k) ! order of indexes depends on the definition of xyz_dist
         ELSE
            df_dx(k,j) = 0.d0
            df_dy(k,j) = 0.d0
            df_dz(k,j) = 0.d0
         END IF
      END DO
   END DO
!$OMP END DO

!$OMP SECTIONS PRIVATE(i)
!$OMP SECTION
Do k = 1,natom
	mgo_dcn_dx(k) = + SUM(df_dx(1:natom, k))
   DO i = 1, natom
      ! No factor 2 here: this is derivative of cn(i) w.r.o. x(i), not total cn w.r.o. x(i)
	  !sum over all j/=k and subtract df_dx(k,i)
	  !force on k-th atom is a sum of contribution from all atom i and j/=k
      mgo_dcn_dx(k) = mgo_dcn_dx(k) - df_dx(k,i)
   END DO
 ENDDO
!$OMP SECTION
   DO k = 1, natom
     mgo_dcn_dy(k) = SUM(df_dy(1:natom, k))
     DO i = 1, natom
         mgo_dcn_dy(k) = mgo_dcn_dy(k) - df_dy(k,i)
     END DO
   END DO
!$OMP SECTION
DO k = 1, natom
    mgo_dcn_dz(k) = SUM(df_dz(1:natom, k))
   DO i = 1, natom
       mgo_dcn_dz(k) = mgo_dcn_dz(k) - df_dz(k,i)
   END DO
 END DO
!$OMP END SECTIONS
!$OMP END PARALLEL
   !---------------------------------------------------------------------------
   !t_end = OMP_GET_WTIME()                                     !>>> CPU_TIME
   !! Writing the cpu time for the subroutine                   !>>> CPU_TIME
   !WRITE(500,'(1I10, 4X, 1F10.8)') ipas, t_end -t_start        !>>> CPU_TIME
   DEALLOCATE (dij, df_dx,df_dy,df_dz)
END SUBROUTINE mgo_coord_fb


      SUBROUTINE MEMCOF(DATA,N,M,PM,COF,WK1,WK2,WKM)
      DIMENSION DATA(N),COF(M),WK1(N),WK2(N),WKM(M)
      P=0.
      DO 11 J=1,N
        P=P+DATA(J)**2
11    CONTINUE
      PM=P/N
      WK1(1)=DATA(1)
      WK2(N-1)=DATA(N)
      DO 12 J=2,N-1
        WK1(J)=DATA(J)
        WK2(J-1)=DATA(J)
12    CONTINUE
      DO 17 K=1,M
        PNEUM=0.
        DENOM=0.
        DO 13 J=1,N-K
          PNEUM=PNEUM+WK1(J)*WK2(J)
          DENOM=DENOM+WK1(J)**2+WK2(J)**2
13      CONTINUE
        COF(K)=2.*PNEUM/DENOM
        PM=PM*(1.-COF(K)**2)
        IF(K.NE.1)THEN
          DO 14 I=1,K-1
            COF(I)=WKM(I)-COF(K)*WKM(K-I)
14        CONTINUE
        ENDIF
        IF(K.EQ.M)RETURN
        DO 15 I=1,K
          WKM(I)=COF(I)
15      CONTINUE
        DO 16 J=1,N-K-1
          WK1(J)=WK1(J)-WKM(K)*WK2(J)
          WK2(J)=WK2(J+1)-WKM(K)*WK1(J+1)
16      CONTINUE
17    CONTINUE
      PAUSE 'never get here'
      END


!*==dgeevx.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DGEEVX + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
!                          VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM,
!                          RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          BALANC, JOBVL, JOBVR, SENSE
!       INTEGER            IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
!       DOUBLE PRECISION   ABNRM
!       ..
!       .. Array Arguments ..
!       INTEGER            IWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), RCONDE( * ), RCONDV( * ),
!      $                   SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   WI( * ), WORK( * ), WR( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
!> eigenvalues and, optionally, the left and/or right eigenvectors.
!>
!> Optionally also, it computes a balancing transformation to improve
!> the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
!> SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
!> (RCONDE), and reciprocal condition numbers for the right
!> eigenvectors (RCONDV).
!>
!> The right eigenvector v(j) of A satisfies
!>                  A * v(j) = lambda(j) * v(j)
!> where lambda(j) is its eigenvalue.
!> The left eigenvector u(j) of A satisfies
!>               u(j)**H * A = lambda(j) * u(j)**H
!> where u(j)**H denotes the conjugate-transpose of u(j).
!>
!> The computed eigenvectors are normalized to have Euclidean norm
!> equal to 1 and largest component real.
!>
!> Balancing a matrix means permuting the rows and columns to make it
!> more nearly upper triangular, and applying a diagonal similarity
!> transformation D * A * D**(-1), where D is a diagonal matrix, to
!> make its rows and columns closer in norm and the condition numbers
!> of its eigenvalues and eigenvectors smaller.  The computed
!> reciprocal condition numbers correspond to the balanced matrix.
!> Permuting rows and columns will not change the condition numbers
!> (in exact arithmetic) but diagonal scaling will.  For further
!> explanation of balancing, see section 4.10.2 of the LAPACK
!> Users' Guide.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] BALANC
!> \verbatim
!>          BALANC is CHARACTER*1
!>          Indicates how the input matrix should be diagonally scaled
!>          and/or permuted to improve the conditioning of its
!>          eigenvalues.
!>          = 'N': Do not diagonally scale or permute;
!>          = 'P': Perform permutations to make the matrix more nearly
!>                 upper triangular. Do not diagonally scale;
!>          = 'S': Diagonally scale the matrix, i.e. replace A by
!>                 D*A*D**(-1), where D is a diagonal matrix chosen
!>                 to make the rows and columns of A more equal in
!>                 norm. Do not permute;
!>          = 'B': Both diagonally scale and permute A.
!>
!>          Computed reciprocal condition numbers will be for the matrix
!>          after balancing and/or permuting. Permuting does not change
!>          condition numbers (in exact arithmetic), but balancing does.
!> \endverbatim
!>
!> \param[in] JOBVL
!> \verbatim
!>          JOBVL is CHARACTER*1
!>          = 'N': left eigenvectors of A are not computed;
!>          = 'V': left eigenvectors of A are computed.
!>          If SENSE = 'E' or 'B', JOBVL must = 'V'.
!> \endverbatim
!>
!> \param[in] JOBVR
!> \verbatim
!>          JOBVR is CHARACTER*1
!>          = 'N': right eigenvectors of A are not computed;
!>          = 'V': right eigenvectors of A are computed.
!>          If SENSE = 'E' or 'B', JOBVR must = 'V'.
!> \endverbatim
!>
!> \param[in] SENSE
!> \verbatim
!>          SENSE is CHARACTER*1
!>          Determines which reciprocal condition numbers are computed.
!>          = 'N': None are computed;
!>          = 'E': Computed for eigenvalues only;
!>          = 'V': Computed for right eigenvectors only;
!>          = 'B': Computed for eigenvalues and right eigenvectors.
!>
!>          If SENSE = 'E' or 'B', both left and right eigenvectors
!>          must also be computed (JOBVL = 'V' and JOBVR = 'V').
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the N-by-N matrix A.
!>          On exit, A has been overwritten.  If JOBVL = 'V' or
!>          JOBVR = 'V', A contains the real Schur form of the balanced
!>          version of the input matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] WR
!> \verbatim
!>          WR is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] WI
!> \verbatim
!>          WI is DOUBLE PRECISION array, dimension (N)
!>          WR and WI contain the real and imaginary parts,
!>          respectively, of the computed eigenvalues.  Complex
!>          conjugate pairs of eigenvalues will appear consecutively
!>          with the eigenvalue having the positive imaginary part
!>          first.
!> \endverbatim
!>
!> \param[out] VL
!> \verbatim
!>          VL is DOUBLE PRECISION array, dimension (LDVL,N)
!>          If JOBVL = 'V', the left eigenvectors u(j) are stored one
!>          after another in the columns of VL, in the same order
!>          as their eigenvalues.
!>          If JOBVL = 'N', VL is not referenced.
!>          If the j-th eigenvalue is real, then u(j) = VL(:,j),
!>          the j-th column of VL.
!>          If the j-th and (j+1)-st eigenvalues form a complex
!>          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
!>          u(j+1) = VL(:,j) - i*VL(:,j+1).
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.  LDVL >= 1; if
!>          JOBVL = 'V', LDVL >= N.
!> \endverbatim
!>
!> \param[out] VR
!> \verbatim
!>          VR is DOUBLE PRECISION array, dimension (LDVR,N)
!>          If JOBVR = 'V', the right eigenvectors v(j) are stored one
!>          after another in the columns of VR, in the same order
!>          as their eigenvalues.
!>          If JOBVR = 'N', VR is not referenced.
!>          If the j-th eigenvalue is real, then v(j) = VR(:,j),
!>          the j-th column of VR.
!>          If the j-th and (j+1)-st eigenvalues form a complex
!>          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
!>          v(j+1) = VR(:,j) - i*VR(:,j+1).
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1, and if
!>          JOBVR = 'V', LDVR >= N.
!> \endverbatim
!>
!> \param[out] ILO
!> \verbatim
!>          ILO is INTEGER
!> \endverbatim
!>
!> \param[out] IHI
!> \verbatim
!>          IHI is INTEGER
!>          ILO and IHI are integer values determined when A was
!>          balanced.  The balanced A(i,j) = 0 if I > J and
!>          J = 1,...,ILO-1 or I = IHI+1,...,N.
!> \endverbatim
!>
!> \param[out] SCALE
!> \verbatim
!>          SCALE is DOUBLE PRECISION array, dimension (N)
!>          Details of the permutations and scaling factors applied
!>          when balancing A.  If P(j) is the index of the row and column
!>          interchanged with row and column j, and D(j) is the scaling
!>          factor applied to row and column j, then
!>          SCALE(J) = P(J),    for J = 1,...,ILO-1
!>                   = D(J),    for J = ILO,...,IHI
!>                   = P(J)     for J = IHI+1,...,N.
!>          The order in which the interchanges are made is N to IHI+1,
!>          then 1 to ILO-1.
!> \endverbatim
!>
!> \param[out] ABNRM
!> \verbatim
!>          ABNRM is DOUBLE PRECISION
!>          The one-norm of the balanced matrix (the maximum
!>          of the sum of absolute values of elements of any column).
!> \endverbatim
!>
!> \param[out] RCONDE
!> \verbatim
!>          RCONDE is DOUBLE PRECISION array, dimension (N)
!>          RCONDE(j) is the reciprocal condition number of the j-th
!>          eigenvalue.
!> \endverbatim
!>
!> \param[out] RCONDV
!> \verbatim
!>          RCONDV is DOUBLE PRECISION array, dimension (N)
!>          RCONDV(j) is the reciprocal condition number of the j-th
!>          right eigenvector.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.   If SENSE = 'N' or 'E',
!>          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
!>          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).
!>          For good performance, LWORK must generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (2*N-2)
!>          If SENSE = 'N' or 'E', not referenced.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  if INFO = i, the QR algorithm failed to compute all the
!>                eigenvalues, and no eigenvectors or condition numbers
!>                have been computed; elements 1:ILO-1 and i+1:N of WR
!>                and WI contain eigenvalues which have converged.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!  @precisions fortran d -> s
!
!> \ingroup doubleGEeigen
!
!  =====================================================================
      SUBROUTINE DGEEVX(Balanc,Jobvl,Jobvr,Sense,N,A,Lda,Wr,Wi,Vl,Ldvl, &
     &                  Vr,Ldvr,Ilo,Ihi,Scale,Abnrm,Rconde,Rcondv,Work, &
     &                  Lwork,Iwork,Info)
      IMPLICIT NONE
!*--DGEEVX309
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Balanc , Jobvl , Jobvr , Sense
      INTEGER Ihi , Ilo , Info , Lda , Ldvl , Ldvr , Lwork , N
      DOUBLE PRECISION Abnrm
!     ..
!     .. Array Arguments ..
      INTEGER Iwork(*)
      DOUBLE PRECISION A(Lda,*) , Rconde(*) , Rcondv(*) , Scale(*) ,    &
     &                 Vl(Ldvl,*) , Vr(Ldvr,*) , Wi(*) , Work(*) , Wr(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D0,ONE=1.0D0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , scalea , wantvl , wantvr , wntsnb , wntsne ,     &
     &        wntsnn , wntsnv
      CHARACTER job , side
      INTEGER hswork , i , icond , ierr , itau , iwrk , k ,             &
     &        lwork_trevc , maxwrk , minwrk , nout
      DOUBLE PRECISION anrm , bignum , cs , cscale , eps , r , scl ,    &
     &                 smlnum , sn
!     ..
!     .. Local Arrays ..
      LOGICAL select(1)
      DOUBLE PRECISION dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DGEBAK , DGEBAL , DGEHRD , DHSEQR , DLABAD , DLACPY ,    &
     &         DLARTG , DLASCL , DORGHR , DROT , DSCAL , DTREVC3 ,      &
     &         DTRSNA , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER IDAMAX , ILAENV
      DOUBLE PRECISION DLAMCH , DLANGE , DLAPY2 , DNRM2
      EXTERNAL LSAME , IDAMAX , ILAENV , DLAMCH , DLANGE , DLAPY2 ,     &
     &         DNRM2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , SQRT
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      lquery = (Lwork==-1)
      wantvl = LSAME(Jobvl,'V')
      wantvr = LSAME(Jobvr,'V')
      wntsnn = LSAME(Sense,'N')
      wntsne = LSAME(Sense,'E')
      wntsnv = LSAME(Sense,'V')
      wntsnb = LSAME(Sense,'B')
      IF ( .NOT.(LSAME(Balanc,'N') .OR. LSAME(Balanc,'S') .OR.          &
     &     LSAME(Balanc,'P') .OR. LSAME(Balanc,'B')) ) THEN
         Info = -1
      ELSEIF ( (.NOT.wantvl) .AND. (.NOT.LSAME(Jobvl,'N')) ) THEN
         Info = -2
      ELSEIF ( (.NOT.wantvr) .AND. (.NOT.LSAME(Jobvr,'N')) ) THEN
         Info = -3
      ELSEIF ( .NOT.(wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv) .OR.   &
     &         ((wntsne .OR. wntsnb) .AND. .NOT.(wantvl .AND. wantvr)) )&
     &         THEN
         Info = -4
      ELSEIF ( N<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -7
      ELSEIF ( Ldvl<1 .OR. (wantvl .AND. Ldvl<N) ) THEN
         Info = -11
      ELSEIF ( Ldvr<1 .OR. (wantvr .AND. Ldvr<N) ) THEN
         Info = -13
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       NB refers to the optimal block size for the immediately
!       following subroutine, as returned by ILAENV.
!       HSWORK refers to the workspace preferred by DHSEQR, as
!       calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
!       the worst case.)
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            minwrk = 1
            maxwrk = 1
         ELSE
            maxwrk = N + N*ILAENV(1,'DGEHRD',' ',N,1,N,0)
!
            IF ( wantvl ) THEN
               CALL DTREVC3('L','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,N+lwork_trevc)
               CALL DHSEQR('S','V',N,1,N,A,Lda,Wr,Wi,Vl,Ldvl,Work,-1,   &
     &                     Info)
            ELSEIF ( wantvr ) THEN
               CALL DTREVC3('R','B',select,N,A,Lda,Vl,Ldvl,Vr,Ldvr,N,   &
     &                      nout,Work,-1,ierr)
               lwork_trevc = INT(Work(1))
               maxwrk = MAX(maxwrk,N+lwork_trevc)
               CALL DHSEQR('S','V',N,1,N,A,Lda,Wr,Wi,Vr,Ldvr,Work,-1,   &
     &                     Info)
            ELSEIF ( wntsnn ) THEN
               CALL DHSEQR('E','N',N,1,N,A,Lda,Wr,Wi,Vr,Ldvr,Work,-1,   &
     &                     Info)
            ELSE
               CALL DHSEQR('S','N',N,1,N,A,Lda,Wr,Wi,Vr,Ldvr,Work,-1,   &
     &                     Info)
            ENDIF
            hswork = INT(Work(1))
!
            IF ( (.NOT.wantvl) .AND. (.NOT.wantvr) ) THEN
               minwrk = 2*N
               IF ( .NOT.wntsnn ) minwrk = MAX(minwrk,N*N+6*N)
               maxwrk = MAX(maxwrk,hswork)
               IF ( .NOT.wntsnn ) maxwrk = MAX(maxwrk,N*N+6*N)
            ELSE
               minwrk = 3*N
               IF ( (.NOT.wntsnn) .AND. (.NOT.wntsne) )                 &
     &              minwrk = MAX(minwrk,N*N+6*N)
               maxwrk = MAX(maxwrk,hswork)
               maxwrk = MAX(maxwrk,N+(N-1)                              &
     &                  *ILAENV(1,'DORGHR',' ',N,1,N,-1))
               IF ( (.NOT.wntsnn) .AND. (.NOT.wntsne) )                 &
     &              maxwrk = MAX(maxwrk,N*N+6*N)
               maxwrk = MAX(maxwrk,3*N)
            ENDIF
            maxwrk = MAX(maxwrk,minwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -21
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DGEEVX',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Get machine constants
!
      eps = DLAMCH('P')
      smlnum = DLAMCH('S')
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
      smlnum = SQRT(smlnum)/eps
      bignum = ONE/smlnum
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      icond = 0
      anrm = DLANGE('M',N,N,A,Lda,dum)
      scalea = .FALSE.
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
         scalea = .TRUE.
         cscale = smlnum
      ELSEIF ( anrm>bignum ) THEN
         scalea = .TRUE.
         cscale = bignum
      ENDIF
      IF ( scalea ) CALL DLASCL('G',0,0,anrm,cscale,N,N,A,Lda,ierr)
!
!     Balance the matrix and compute ABNRM
!
      CALL DGEBAL(Balanc,N,A,Lda,Ilo,Ihi,Scale,ierr)
      Abnrm = DLANGE('1',N,N,A,Lda,dum)
      IF ( scalea ) THEN
         dum(1) = Abnrm
         CALL DLASCL('G',0,0,cscale,anrm,1,1,dum,1,ierr)
         Abnrm = dum(1)
      ENDIF
!
!     Reduce to upper Hessenberg form
!     (Workspace: need 2*N, prefer N+N*NB)
!
      itau = 1
      iwrk = itau + N
      CALL DGEHRD(N,Ilo,Ihi,A,Lda,Work(itau),Work(iwrk),Lwork-iwrk+1,   &
     &            ierr)
!
      IF ( wantvl ) THEN
!
!        Want left eigenvectors
!        Copy Householder vectors to VL
!
         side = 'L'
         CALL DLACPY('L',N,N,A,Lda,Vl,Ldvl)
!
!        Generate orthogonal matrix in VL
!        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
!
         CALL DORGHR(N,Ilo,Ihi,Vl,Ldvl,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VL
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         iwrk = itau
         CALL DHSEQR('S','V',N,Ilo,Ihi,A,Lda,Wr,Wi,Vl,Ldvl,Work(iwrk),  &
     &               Lwork-iwrk+1,Info)
!
         IF ( wantvr ) THEN
!
!           Want left and right eigenvectors
!           Copy Schur vectors to VR
!
            side = 'B'
            CALL DLACPY('F',N,N,Vl,Ldvl,Vr,Ldvr)
         ENDIF
!
      ELSEIF ( wantvr ) THEN
!
!        Want right eigenvectors
!        Copy Householder vectors to VR
!
         side = 'R'
         CALL DLACPY('L',N,N,A,Lda,Vr,Ldvr)
!
!        Generate orthogonal matrix in VR
!        (Workspace: need 2*N-1, prefer N+(N-1)*NB)
!
         CALL DORGHR(N,Ilo,Ihi,Vr,Ldvr,Work(itau),Work(iwrk),           &
     &               Lwork-iwrk+1,ierr)
!
!        Perform QR iteration, accumulating Schur vectors in VR
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         iwrk = itau
         CALL DHSEQR('S','V',N,Ilo,Ihi,A,Lda,Wr,Wi,Vr,Ldvr,Work(iwrk),  &
     &               Lwork-iwrk+1,Info)
!
      ELSE
!
!        Compute eigenvalues only
!        If condition numbers desired, compute Schur form
!
         IF ( wntsnn ) THEN
            job = 'E'
         ELSE
            job = 'S'
         ENDIF
!
!        (Workspace: need 1, prefer HSWORK (see comments) )
!
         iwrk = itau
         CALL DHSEQR(job,'N',N,Ilo,Ihi,A,Lda,Wr,Wi,Vr,Ldvr,Work(iwrk),  &
     &               Lwork-iwrk+1,Info)
      ENDIF
!
!     If INFO .NE. 0 from DHSEQR, then quit
!
      IF ( Info==0 ) THEN
!
!
!        Compute left and/or right eigenvectors
!        (Workspace: need 3*N, prefer N + 2*N*NB)
!
         IF ( wantvl .OR. wantvr ) CALL DTREVC3(side,'B',select,N,A,Lda,&
     &        Vl,Ldvl,Vr,Ldvr,N,nout,Work(iwrk),Lwork-iwrk+1,ierr)
!
!     Compute condition numbers if desired
!     (Workspace: need N*N+6*N unless SENSE = 'E')
!
         IF ( .NOT.wntsnn ) CALL DTRSNA(Sense,'A',select,N,A,Lda,Vl,    &
     &                                  Ldvl,Vr,Ldvr,Rconde,Rcondv,N,   &
     &                                  nout,Work(iwrk),N,Iwork,icond)
!
         IF ( wantvl ) THEN
!
!        Undo balancing of left eigenvectors
!
            CALL DGEBAK(Balanc,'L',N,Ilo,Ihi,Scale,N,Vl,Ldvl,ierr)
!
!        Normalize left eigenvectors and make largest component real
!
            DO i = 1 , N
               IF ( Wi(i)==ZERO ) THEN
                  scl = ONE/DNRM2(N,Vl(1,i),1)
                  CALL DSCAL(N,scl,Vl(1,i),1)
               ELSEIF ( Wi(i)>ZERO ) THEN
                  scl = ONE/DLAPY2(DNRM2(N,Vl(1,i),1),                  &
     &                  DNRM2(N,Vl(1,i+1),1))
                  CALL DSCAL(N,scl,Vl(1,i),1)
                  CALL DSCAL(N,scl,Vl(1,i+1),1)
                  DO k = 1 , N
                     Work(k) = Vl(k,i)**2 + Vl(k,i+1)**2
                  ENDDO
                  k = IDAMAX(N,Work,1)
                  CALL DLARTG(Vl(k,i),Vl(k,i+1),cs,sn,r)
                  CALL DROT(N,Vl(1,i),1,Vl(1,i+1),1,cs,sn)
                  Vl(k,i+1) = ZERO
               ENDIF
            ENDDO
         ENDIF
!
         IF ( wantvr ) THEN
!
!        Undo balancing of right eigenvectors
!
            CALL DGEBAK(Balanc,'R',N,Ilo,Ihi,Scale,N,Vr,Ldvr,ierr)
!
!        Normalize right eigenvectors and make largest component real
!
            DO i = 1 , N
               IF ( Wi(i)==ZERO ) THEN
                  scl = ONE/DNRM2(N,Vr(1,i),1)
                  CALL DSCAL(N,scl,Vr(1,i),1)
               ELSEIF ( Wi(i)>ZERO ) THEN
                  scl = ONE/DLAPY2(DNRM2(N,Vr(1,i),1),                  &
     &                  DNRM2(N,Vr(1,i+1),1))
                  CALL DSCAL(N,scl,Vr(1,i),1)
                  CALL DSCAL(N,scl,Vr(1,i+1),1)
                  DO k = 1 , N
                     Work(k) = Vr(k,i)**2 + Vr(k,i+1)**2
                  ENDDO
                  k = IDAMAX(N,Work,1)
                  CALL DLARTG(Vr(k,i),Vr(k,i+1),cs,sn,r)
                  CALL DROT(N,Vr(1,i),1,Vr(1,i+1),1,cs,sn)
                  Vr(k,i+1) = ZERO
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
!     Undo scaling if necessary
!
      IF ( scalea ) THEN
         CALL DLASCL('G',0,0,cscale,anrm,N-Info,1,Wr(Info+1),           &
     &               MAX(N-Info,1),ierr)
         CALL DLASCL('G',0,0,cscale,anrm,N-Info,1,Wi(Info+1),           &
     &               MAX(N-Info,1),ierr)
         IF ( Info==0 ) THEN
            IF ( (wntsnv .OR. wntsnb) .AND. icond==0 )                  &
     &           CALL DLASCL('G',0,0,cscale,anrm,N,1,Rcondv,N,ierr)
         ELSE
            CALL DLASCL('G',0,0,cscale,anrm,Ilo-1,1,Wr,N,ierr)
            CALL DLASCL('G',0,0,cscale,anrm,Ilo-1,1,Wi,N,ierr)
         ENDIF
      ENDIF
!
      Work(1) = maxwrk
!
!     End of DGEEVX
!
      END SUBROUTINE DGEEVX


SUBROUTINE bim_cn_light
   !======================
   ! CN_bim light version
   !======================
   ! Make use of this version when running computationally slow, taxing simulations i.e large clusters and long simulations.
   ! No derivatives are calculated in this version to speed calculation times and save memory.
   !=====================
   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer               :: i, j, itypik, mminusn_pwr
   double precision      :: ratio_ton, ratio_tom
   double precision      :: dij0, dij, ratio
   real(8), dimension(3) :: rij0 ! 3 possible cases: atoms A-A, B-B, A-B

   if (ipas.eq.1) write(*,*) 'bim_cn_light> first calculation of CN_bim'

   mminusn_pwr = cn_m_pwr - cn_n_pwr

   ! Evaluating the values of rij0 parameter in dependence of atom pair kind
   rij0 = dist * cn_rzero * dsqrt(2.d0)

   ! For 'false' pairs and elements on the diagonal
   cn_s = 0.d0

   do i = 1, natom-1
      do j = i+1, natom
         IF (pair_yesno_mat(j,i)) THEN
		 ! Checking what kind of atoms the couple i,j is made of
		 if      ((itype(i).eq.1).and.(itype(j).eq.1)) then
		    itypik = 1  ! same metal A
		 else if ((itype(i).eq.2).and.(itype(j).eq.2)) then
		    itypik = 2  ! same metal B
		 else
		    itypik = 3  ! A-B interaction
		 end if

		 ! Evaluating the ref distance for the couple of atoms
		 dij0 = dist(itypik)

		 ! Calculating the distance between atom i and atom j
		 dij = pair_dist (i,j) - dij0

		 ! Calculating the analytic coordination number
		 if (dij.le.0) then
		    ! The sum of these s(i,j) is the analytic coord no.
		    cn_s(i,j) = 1.d0
		    cn_s(j,i) = cn_s(i,j)
		 else
		    ratio = dij/rij0(itypik)
		    ! I need to rise to (X_pwr-1) for the derivative
		    ratio_ton = ratio**(cn_n_pwr)
		    ratio_tom = ratio_ton*(ratio**(mminusn_pwr))

		    ! The sum of these s(i,j) is the analytic coord no.
		    cn_s(i,j) = (1.d0-ratio_ton)/(1.d0-ratio_tom)  ! this is f(rij)
		    cn_s(j,i) = cn_s(i,j)
	 	 end if
         ENDIF
      end do ! on j
   end do ! on i

   ! LP: Calculating the sum of s(i,j), which is CNatom(i), global.
   ! This is the coord num of any single atom i
   cn_CNatom(:) = 0.d0 ! Initializing
   do i = 1, natom
      do  j = 1, natom
         cn_CNatom(i) = cn_CNatom(i) + cn_s(j, i)
      end do
   end do

END SUBROUTINE bim_cn_light


Subroutine Fuerzas (L)

  Use cte

  Implicit None

  Real :: Enpot, Fxij, Fyij, Fzij
  Real :: Ps1, Ps2
  Real :: xij, yij, zij, Fxi, Fyi, Fzi, rij
  Integer :: i, j, L

  Enpot = 0.0

  Fx = 0.0
  Fy = 0.0
  Fz = 0.0

  Du2 = 0.0

  DO i = 1, Nc - 1

     Fxi = Fx(i)
     Fyi = Fy(i)
     Fzi = Fz(i)

     DO j = i + 1, Nc

        xij = X(i) - X(j)
        yij = Y(i) - Y(j)
        zij = Z(i) - Z(j)

        !EFECTO PACMAN
        xij = xij - Ls*Anint(xij/Ls)
        yij = yij - Ls*Anint(yij/Ls)
        zij = zij - Ls*Anint(zij/Ls)

        rij = sqrt(xij**2 + yij**2 + zij**2)

        ! Modelo de potencial

        If (rij .LT. RCut) Then
           ! Yukawa
           !U   = exp(-ZK * rij)
           !U2  = A * U *(ZK * rij + 1)/(rij ** 3)
           !DOBLE GAUSSIANO
           U = (1.0/T)*exp(-(rij**2))-eta*exp(-(rij-ji)**2)
           U2 = 2.0*(U + ( (eta*ji) * exp(-(rij-ji)**2 ) ) / rij )

           Du2 = (2.0 * U * rij * rij) + Du2

           Enpot = U + Enpot

           Fxij = (xij)* U2
           Fyij = (yij)* U2
           Fzij = (zij)* U2

           Fxi = Fxi + Fxij
           Fyi = Fyi + Fyij
           Fzi = Fzi + Fzij

           FX(j) = FX(j) - Fxij
           FY(j) = FY(j) - Fyij
           FZ(j) = FZ(j) - Fzij

        End If

        Fx(i) = Fxi
        Fy(i) = Fyi
        Fz(i) = Fzi

     End Do

  End Do

  ! Calculo de la presion

  Ps1 = ns + (ns/ (3.0 * Real(Nc))) * Du2

  Write(16, *) L, Enpot/real(Nc)

  If (MOD(L, NFREC).EQ.0.0)   Then

    Write(*,*)  L, Enpot/real(Nc), Ps1

  End If

End Subroutine Fuerzas