    SUBROUTINE SGEGS_F95( A, B, ALPHAR, ALPHAI, BETA, VSL, VSR, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => SP
   USE LA_AUXMOD, ONLY: ERINFO
   USE F77_LAPACK, ONLY: GEGS_F77 => LA_GEGS
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: ALPHAR(:), ALPHAI(:), BETA(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: VSL(:,:), VSR(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
!  LA_GEGS computes for a pair of n-by-n real nonsymmetric matrices
!  A, B: the generalized eigenvalues (alphar alpha, beta),
!  the Schur form (A, B), and optionally left and/or right
!  Schur vectors (VSL and VSR).
!
!  (If only the generalized eigenvalues are needed, use the driver SGEGV
!  instead.)
!
!  A generalized eigenvalue for a pair of matrices (A,B) is, roughly
!  speaking, a scalar w or a ratio  alpha/beta = w, such that  A - w*B
!  is singular.  It is usually represented as the pair (alpha,beta),
!  as there is a reasonable interpretation for beta=0, and even for
!  both being zero.  A good beginning reference is the book, "Matrix
!  Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
!
!  The (generalized) Schur form of a pair of matrices is the result of
!  multiplying both matrices on the left by one orthogonal matrix and
!  both on the right by another orthogonal matrix, these two orthogonal
!  matrices being chosen so as to bring the pair of matrices into
!  (real) Schur form.
!
!  A pair of matrices A, B is in generalized real Schur form if B is
!  upper triangular with non-negative diagonal and A is block upper
!  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond
!  to real generalized eigenvalues, while 2-by-2 blocks of A will be
!  "standardized" by making the corresponding elements of B have the
!  form:
!          [  a  0  ]
!          [  0  b  ]
!
!  and the pair of corresponding 2-by-2 blocks in A and B will
!  have a complex conjugate pair of generalized eigenvalues.
!
!  The left and right Schur vectors are the columns of VSL and VSR,
!  respectively, where VSL and VSR are the orthogonal matrices
!  which reduce A and B to Schur form:
!
!  Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) )
!
! =========
!
!   SUBROUTINE LA_GEGS( A, B, <alpha>, BETA, VSL, VSR, INFO )
!      <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
!      <type>(<wp>), INTENT(OUT), OPTIONAL :: <alpha'>, BETA(:)
!      <type>(<wp>), INTENT(OUT), OPTIONAL :: VSL(:,:), VSR(:,:)
!      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   where
!      <type>   ::= REAL | COMPLEX
!      <wp>     ::= KIND(1.0) | KIND(1.0D0)
!      <alpha>  ::= ALPHAR, ALPHAI | ALPHA
!      <alpha'> ::= ALPHAR(:), ALPHAI(:) | ALPHA(:)
!
! Arguments
! =========
!
! A    (input/output) REAL / COMPLEX array, shape (:,:),
!      SIZE(A,1) == SIZE(A,2) == n.
!      On entry, the first of the pair of matrices whose generalized
!      eigenvalues and (optionally) Schur vectors are to be
!      computed.
!      On exit, the generalized Schur form of A.
!      Note: to avoid overflow, the Frobenius norm of the matrix
!      A should be less than the overflow threshold.
!
! B    (input/output) REAL / COMPLEX array, shape (:,:),
!      SIZE(rBA,1) == SIZE(rBA,2) == n.
!      On entry, the second of the pair of matrices whose
!      generalized eigenvalues and (optionally) Schur vectors are
!      to be computed.
!      On exit, the generalized Schur form of B.
!      Note: to avoid overflow, the Frobenius norm of the matrix
!      B should be less than the overflow threshold.
!
! ALPHAR  Only for the real case. Optional (output) REAL array,
! ALPHAI  shape (:), SIZE(ALPHA') == n. ALPHA ::= ALPHAR | ALPHAI
! ALPHA   Only for the complex case. Optional (output) COMPLEX
!         array, shape (:), SIZE(ALPHAI) == n.
! BETA Optional (output) REAL / COMPLEX array, shape (:),
!      SIZE(BETA) == n.
!      On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,n, will
!      be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,
!      j=1,...,n  and  BETA(j),j=1,...,n  are the diagonals of the
!      complex Schur form (A,B) that would result if the 2-by-2
!      diagonal blocks of the real Schur form of (A,B) were further
!      reduced to triangular form using 2-by-2 complex unitary
!      transformations.  If ALPHAI(j) is zero, then the j-th
!      eigenvalue is real; if positive, then the j-th and (j+1)-st
!      eigenvalues are a complex conjugate pair, with ALPHAI(j+1)
!      negative.
!      Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!      may easily over- or underflow, and BETA(j) may even be zero.
!      Thus, the user should avoid naively computing the ratio
!      alpha/beta.  However, ALPHAR and ALPHAI will be always less
!      than and usually comparable with norm(A) in magnitude, and
!      BETA always less than and usually comparable with norm(B).
!
! VSL  Optional (output) REAL / COMPLEX array, shape (:,:),
!      SIZE(VSL,1) == SIZE(VSL,2) == n.
!      VSL will contain the left Schur vectors. (See "Purpose", above.)
!
! VSR  Optional (output) REAL / COMPLEX array, shape (:,:),
!      SIZE(VSL,1) == SIZE(VSL,2) == n.
!      VSR will contain the right Schur vectors. (See "Purpose", above.)
!
! INFO (output) INTEGER
!      = 0:  successful exit
!      < 0:  if INFO = -i, the i-th argument had an illegal value.
!      = 1,...,n:
!            The QZ iteration failed.  (A,B) are not in Schur
!            form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
!            be correct for j=INFO+1,...,n.
!      > n:  errors that usually indicate LAPACK problems:
!            =n+1: error return from LA_GGBAL
!            =n+2: error return from LA_GEQRF
!            =n+3: error return from LA_ORMQR
!            =n+4: error return from LA_ORGQR
!            =n+5: error return from LA_GGHRD
!            =n+6: error return from LA_HGEQZ (other than failed
!                                            iteration)
!            =n+7: error return from LA_GGBAK (computing VSL)
!            =n+8: error return from LA_GGBAK (computing VSR)
!            =n+9: error return from LA_LASCL (various places)
!      If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!-------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GEGS'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBVSL, LJOBVSR
   INTEGER, SAVE :: LWORK = 0
   INTEGER :: N, LINFO, LD, ISTAT, ISTAT1, S1VSL, S2VSL, S1VSR, S2VSR, &
              SALPHAR, SALPHAI, SBETA
!  .. LOCAL ARRAYS ..
   REAL(WP), TARGET :: LLVSL(1,1), LLVSR(1,1)
   REAL(WP), POINTER :: WORK(:), &
     &                   LALPHAR(:), LALPHAI(:), LBETA(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LD = MAX(1,N)
   IF( PRESENT(ALPHAR) )THEN; SALPHAR = SIZE(ALPHAR); ELSE; SALPHAR = N; ENDIF
   IF( PRESENT(ALPHAI) )THEN; SALPHAI = SIZE(ALPHAI); ELSE; SALPHAI = N; ENDIF
   IF( PRESENT(BETA) )THEN; SBETA = SIZE(BETA); ELSE; SBETA = N; ENDIF
   IF( PRESENT(VSL) )THEN; S1VSL = SIZE(VSL,1); S2VSL = SIZE(VSL,2); LJOBVSL = 'V'
   ELSE; S1VSL = 1; S2VSL = 1; LJOBVSL = 'N'; END IF
   IF( PRESENT(VSR) )THEN; S1VSR = SIZE(VSR,1); S2VSR = SIZE(VSR,2); LJOBVSR = 'V'
   ELSE; S1VSR = 1; S2VSR = 1; LJOBVSR = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
   ELSE IF( SIZE(B,1) /= N .OR. SIZE(B,2) /= N )THEN; LINFO = -2
   ELSE IF( SALPHAR /= N )THEN; LINFO = -3
   ELSE IF( SALPHAI /= N )THEN; LINFO = -4
   ELSE IF( SBETA /= N )THEN; LINFO = -5
   ELSE IF( PRESENT(VSL) .AND. ( S1VSL /= N .OR. S2VSL /= N ) )THEN; LINFO = -6
   ELSE IF( PRESENT(VSR) .AND. ( S1VSR /= N .OR. S2VSR /= N ) )THEN; LINFO = -7
   ELSE IF( N > 0 )THEN
      IF( PRESENT(ALPHAR) )THEN; LALPHAR => ALPHAR
      ELSE; ALLOCATE(LALPHAR(N),STAT=ISTAT); ENDIF
      IF( ISTAT == 0 )THEN
         IF( PRESENT(ALPHAI) )THEN; LALPHAI => ALPHAI
         ELSE; ALLOCATE(LALPHAI(N),STAT=ISTAT); ENDIF
      END IF
      IF( ISTAT == 0 )THEN
         IF( PRESENT(BETA) )THEN; LBETA => BETA
         ELSE; ALLOCATE(LBETA(N),STAT=ISTAT); ENDIF
      END IF
      IF( ISTAT == 0 )THEN
         LWORK = MAX( 1, 4*N, LWORK); ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN; DEALLOCATE(WORK,STAT=ISTAT1)
            LWORK = MAX( 1, 4*N ); ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT == 0) CALL ERINFO( -200, SRNAME, LINFO )
         END IF
      END IF
      IF( ISTAT == 0 ) THEN
         IF( PRESENT(VSL) )THEN
           IF( PRESENT(VSR) )THEN
              CALL GEGS_F77( LJOBVSL, LJOBVSR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, VSL, S1VSL, VSR, S1VSR, WORK, LWORK, LINFO )
	   ELSE
	      CALL GEGS_F77( LJOBVSL, LJOBVSR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, VSL, S1VSL, LLVSR, S1VSR, WORK, LWORK, LINFO )
	   ENDIF
	 ELSE
	   IF( PRESENT(VSR) )THEN
	      CALL GEGS_F77( LJOBVSL, LJOBVSR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, LLVSL, S1VSL, VSR, S1VSR, WORK, LWORK, LINFO )
	   ELSE
	      CALL GEGS_F77( LJOBVSL, LJOBVSR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, LLVSL, S1VSL, LLVSR, S1VSR, WORK, LWORK, LINFO )
	   ENDIF
	 ENDIF
         IF( LINFO == 0 ) LWORK = INT(WORK(1)+1)
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE SGEGS_F95


PROGRAM MANYBODYHUBBARD

  USE ATOMIC_PROPERTIES
  USE TYPES
  USE SUBINTERFACE
  USE SUBINTERFACE_LAPACK
  USE FLOQUETINITINTERFACE
  USE ARRAYS

  IMPLICIT NONE
  TYPE(MODE),       DIMENSION(:),   ALLOCATABLE :: FIELDS
  TYPE(ATOM)                                       ID
  INTEGER,          DIMENSION(:),   ALLOCATABLE :: MODES_NUM
  INTEGER                                          TOTAL_FREQUENCIES,D_BARE
  INTEGER                                          INFO,m,INDEX0,r
  DOUBLE PRECISION, DIMENSION(:),   ALLOCATABLE :: ENERGY,E_FLOQUET,E_BARE
  COMPLEX*16,       DIMENSION(:,:), ALLOCATABLE :: H_J,H_U,U_F,H_BARE
  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: P_AVG
  INTEGER         , DIMENSION(:,:), ALLOCATABLE :: states_occ
  DOUBLE PRECISION                              :: T1,T2

  INTEGER index,N_BODIES,N_SITES,i_,M_
  DOUBLE PRECISION t,u,t_driv,omega,D_H

  OPEN(UNIT=3,FILE="ManybodyHubbard_Bosons.dat",ACTION="WRITE")

  INFO = 0
  N_BODIES = 7

  N_SITES  = 3

  D_BARE = D_H(N_SITES,N_BODIES,'B')  ! D_H EVALUATES THE NUMBER OF STATES
  write(*,*) '# Number of lattice sites:         ', N_SITES
  write(*,*) '# Number of particles:             ', N_BODIES
  write(*,*) '# Number of states Bosonic states  ', D_BARE
  write(*,*)
  write(*,*)

  CALL FLOQUETINIT(ID,'lattice',0.1d1*D_BARE,INFO)

  ALLOCATE(E_BARE(D_BARE))             ! STORE THE ENERGY SPECTRUM
  ALLOCATE(H_BARE(D_BARE,D_BARE))      ! STORE THE BARE HAMILTONIAN
  ALLOCATE(H_J(D_BARE,D_BARE))         ! STORE THE TUNNENING MATRIX
  ALLOCATE(H_U(D_BARE,D_BARE))         ! STORES THE ONSITE INTERACTION
  ALLOCATE(MODES_NUM(2))               ! NUMBER OF DRIVING MODES

  ALLOCATE(states_occ(D_BARE,N_SITES)) ! STORES THE STATES USING OCCUPATION NUMBER

   ! CREATE THE BASIS OF STATES
  CALL Manybody_basis(D_BARE,N_SITES,N_BODIES,'B',states_occ,INFO)
  !call write_matrix_int(states_occ)

!  ! EVALUATE THE TUNNELING TERM OF THE HAMILTONIAN

  CALL Tunneling_B(D_BARE,N_SITES,N_BODIES,STATES_OCC,H_J,INFO)
!  !CALL WRITE_MATRIX(abs(h_j))
!  !! EVALUATE THE ON-SITE INTERACTION

  CALL Onsite_twobody_B(D_BARE,N_SITES,N_BODIES,STATES_OCC,H_U,INFO)
!  !CALL WRITE_MATRIX(abs(h_u))
!
  !NOW DEFINE THE DRIVING
  MODES_NUM(1) = 1 !(STATIC FIELD)
  MODES_NUM(2) = 1 !(DRIVING BY ONE HARMONIC)
!
  TOTAL_FREQUENCIES = SUM(MODES_NUM,1)
  ALLOCATE(FIELDS(TOTAL_FREQUENCIES))
  DO m=1,TOTAL_FREQUENCIES
     ALLOCATE(FIELDS(m)%V(D_BARE,D_BARE))
     FIELDS(m)%V = 0.0
  END DO

  ! HUBBARD MODEL PARAMETERS
  t      = 1.0
  u      = 0.5

  !DRIVING PARAMETERS
  t_driv = 0.2
  omega  = 1.0

  ! DEFINE THE TOTAL STATIC HAMILTONIAN USIING THE TUNNELING AND ON-SITE INTERACTIONS
  FIELDS(1)%V         = -t*H_J + u*H_U
  FIELDS(1)%omega     = 0
  FIELDS(1)%N_Floquet = 0

  ! DEFINE THE DRIVING TERM OF THE HAMILTONIAN.
  FIELDS(2)%V         = t_driv*H_J
  FIELDS(2)%omega     = omega
  FIELDS(2)%N_Floquet = 2

  write(*,*) '# Hubbard parameters (t,u):',t,u
  write(*,*) '# Driving parameters (t_driving,omega,N_Floquet):',t_driv,omega,FIELDS(2)%N_Floquet
  write(*,*) '# Floquet spectrum as a function of the driving frequency (first column))'

  ! EVALUATE THE SPECTRUM OF THE STATIC HAMILTONIAN
  H_BARE = FIELDS(1)%V
  CALL LAPACK_FULLEIGENVALUES(H_BARE,D_BARE,E_BARE,INFO)
  M_=32
  DO m=1,M_ ! SCAN DRIVING FREQUENCY
    FIELDS(2)%omega     = 0.1 + (m-1)*1.0/M_
    CALL MULTIMODEFLOQUETMATRIX(ID,size(modes_num,1),total_frequencies,MODES_NUM,FIELDS,INFO)
!  !CALL WRITE_MATRIX(ABS(H_FLOUET()))
!
    ALLOCATE(E_FLOQUET(SIZE(H_FLOQUET,1)))
    ALLOCATE(U_F(SIZE(H_FLOQUET,1),SIZE(H_FLOQUET,1)))
    E_FLOQUET = 0.0
!
    CALL LAPACK_FULLEIGENVALUES(H_FLOQUET,SIZE(H_FLOQUET,1),E_FLOQUET,INFO)
    U_F = H_FLOQUET ! FOURIER DECOMPOSITION OF THE STATES DRESSED BY MODE NUMBER
    WRITE(3,*) FIELDS(2)%omega,E_FLOQUET
    DEALLOCATE(H_FLOQUET)
    DEALLOCATE(E_FLOQUET)
    DEALLOCATE(U_F)

  END DO

END PROGRAM MANYBODYHUBBARD


module kd_tree
  !! Provides routines for a k-dimensional tree, a space-partitioning data structure used for organizing points in k-dimensional space. Note that nearest neightbor searches within k-d trees are not suitable for high dimensional space and will likely perform no better than an exhaustive search. As a general rule of thumb, \(N \gg 2^k\). For an introduction to k-d trees, see "An introductory tutorial on kd-trees" (Andrew Moore, 1991).

  type kdbox
     !! Represents a hyperrectangle / box / n-orthotope)
     real :: min, max
  end type kdbox

  type kdnode
     !! Represents a node in the kdtree
     private
     integer :: split
     !! The split dimension of this node
     type(kdnode), pointer :: left, right
     !! The left and right child nodes
     type(kdbox), pointer :: orthotope => null()
     !! The bounding hyperrectangle of this node
  end type kdnode

  type kdtree
     !! Represents the kdtree itself
     real, pointer :: set(:,:) => null()
     !! The input (sorted, row-major) data set associated with this kd tree
     type(kdnode), pointer :: root => null()
     !! The root node of the kd tree
     integer :: dim = 0
     !! The rank of the data set's domain
     integer :: num = 0
     !! The rank of the data set's range
  end type kdtree

contains

  function build_Kd_Tree(S) result(kdt)
    !! UX to build a balanced k-d tree from a set of sorted data points, /(S/).
    !! @warning Note that /(S/) must be input as a *row-major* array, /(\texttt{S(1:dim, 1:num)}/),
    !! NOT in Fortran's usual column-major notation.

    use statistics, only: median
    use assert, only: assert_x_is_ge_y

    real, target :: S(:,:)
    type(kdtree), pointer :: kdt

    ! Store data set and properties in kdtree structure
    allocate(kdt)
    kdt%set => S
    kdt%dim = size(S,1)
    kdt%num = size(S,2)

    ! The number of data points must be greater than the number of its dimensions.
    call assert_x_is_ge_y(kdt%num, kdt%dim)

    ! The data set is bounded by a _dim_-orthotope. Find these bounds.

    ! Recursively build the kd tree
    kdt%root => build(kdt)

    ! The root of the kd tree is determined by the initial split dimension, which we set
    ! as the median of the (sorted) data set.

    ! Recursively build the tree

  end function build_Kd_Tree

  recursive function build(tree) result (node)

    type(kdtree), pointer :: tree
    type(kdnode), pointer :: node

  end function build

end module kd_tree


module jump_integration

    use quadpack_double

    implicit none

    real (kind = 8) N, P_CUTOFF, ALPHA
    real (kind = 8) kernel_p, kernel_q

    real (kind = 8), parameter :: PI = 4.D0 * DATAN(1.D0)
    real (kind = 8) x0, sigma

    integer (kind = 4) FUN_TYPE

contains

    subroutine JumpModel(N_in, P_CUTOFF_in, ALPHA_in, FUN_TYPE_in)
        integer (kind = 4) N_in, FUN_TYPE_in
        real (kind = 8) P_CUTOFF_in, ALPHA_in

        N = REAL(N_in, kind = 8)
        P_CUTOFF = P_CUTOFF_in
        ALPHA    = ALPHA_in
        FUN_TYPE = FUN_TYPE_in
    end subroutine

    subroutine SetAlpha(ALPHA_in)
        real (kind = 8) ALPHA_in
        ALPHA = ALPHA_in
    end subroutine

    subroutine GaussianCurrentKernel(sigma_in, x0_in)
        real (kind = 8) sigma_in, x0_in

        sigma = sigma_in
        x0 = x0_in

        return
    end subroutine

    function BasisMatrixElement(i, j)
        integer i, j
        real (kind = 8) step, p, q
        complex (kind = 8) BasisMatrixElement

        step = P_CUTOFF / N

        p = step * (i + 0.5)
        q = step * (j + 0.5)

        BasisMatrixElement = step * kernelValue(p, q)
        return
    end function

!created for fixing conservation
    function BasisMatrixElement2(i, j)
        integer i, j
        real (kind = 8) step, p, q
        complex (kind = 8) BasisMatrixElement2

        step = P_CUTOFF / N

        p = step * (i + 0.5)
        q = step * (j + 0.5)

        BasisMatrixElement2 = step * kernelValue2(p, q)
        return
    end function

    ! -------------------------------
    ! JUMP POTENTIAL MODEL
    ! -------------------------------

    function transmit(k)
        real (kind = 8) k
        complex (kind = 8) transmit

        transmit = DCMPLX(k, ALPHA) / DCMPLX(k, -ALPHA)

        return
    end function

    function reflect(k)
        real (kind = 8) k
        complex (kind = 8) reflect

        reflect = DCMPLX(0*k, 0*k)
        return
    end function

    function phi(k, x)
        real (kind = 8) k, x
        complex (kind = 8) phi, incomingWave, reflectWave, transmitWave

        if (x < 0) then
            incomingWave = EXP(DCMPLX(0, k*x))
            reflectWave  = CONJG(incomingWave)
            phi = reflectWave*reflect(k) + incomingWave
        else
            transmitWave = EXP(DCMPLX(0, k*x))
            phi = transmitWave*transmit(k)
        end if
        return
    end function

    function phiDeriv(k, x)
        real (kind = 8) k, x
        complex (kind = 8) phiDeriv, incomingWave, reflectWave, transmitWave

        if (x < 0) then
            incomingWave = EXP(DCMPLX(0, k*x)) * DCMPLX(0, k)
            reflectWave  = CONJG(incomingWave)
            phiDeriv = reflectWave*reflect(k) + incomingWave
        else
            transmitWave = EXP(DCMPLX(0, k*x)) * DCMPLX(0, k)
            phiDeriv = transmitWave*transmit(k)
        end if
        return
    end function

    ! -------------------------------
    ! SCATTERING MODEL
    ! -------------------------------

    function currentKernel(x, k1, k2)
        real (kind = 8) x, k1, k2
        complex (kind = 8) currentKernel, psi1, psi2, psiD1, psiD2, psiDiff

        psi1  = CONJG(phi(k1, x))

        psi2  = phi(k2, x)
        psiD1 = CONJG(phiDeriv(k1, x))
        psiD2 = phiDeriv(k2, x)
        psiDiff = psiD1*psi2 - psi1*psiD2

        currentKernel = DCMPLX(0, 0.25D0/PI) * psiDiff
        return
    end function

    ! -------------------------------
    ! GAUSSIAN CURRENT KERNEL
    ! -------------------------------

    function stepFunction(x)
        real (kind = 8) stepFunction, x

        if (FUN_TYPE .EQ. 1) then

            stepFunction = EXP(- (((x - x0)/sigma)**2)/2) / (sigma * SQRT(2*PI))

        else if (FUN_TYPE .EQ. 2) then

            stepFunction = (2*(sigma)**3)*(1/PI)/((x - x0)**2 + sigma**2)**2

        else if (FUN_TYPE .EQ. 3) then

            if((x < x0 - 0.5) .OR. (x > x0 + 0.5)) then
                stepFunction = 0
            else
                stepFunction = 1
            end if
        end if

        return
    end function

    ! -------------------------------
    ! SPATIAL CURRENT KERNEL
    ! -------------------------------

    function kernelValue(p, q)
        real (kind = 8) x_a, x_b
        real (kind = 8) p, q
        complex (kind = 8) kernelValue

        if (FUN_TYPE .EQ. 1) then
            x_a = x0 - 8*sigma
            x_b = x0 + 8*sigma
        else if (FUN_TYPE .EQ. 2) then
            x_a = x0 - 8*sigma
            x_b = x0 + 8*sigma
        else if (FUN_TYPE .EQ. 3) then
            x_a = x0 - 0.5
            x_b = x0 + 0.5
        end if

        kernelValue = Integrate(x_a, x_b, p, q) !&
        !+ DCMPLX(0, 0.25D0/PI) * stepFunction(0.0D0) * (p + q) * DCMPLX(0, 2*ALPHA)/(DCMPLX(q, -ALPHA)* DCMPLX(p, ALPHA))
        return
    end function

!created to fix the conservation
    function kernelValue2(p, q)
        real (kind = 8) x_a, x_b
        real (kind = 8) p, q
        complex (kind = 8) kernelValue2

        if (FUN_TYPE .EQ. 1) then
            x_a = x0 - 8*sigma
            x_b = x0 + 8*sigma
        else if (FUN_TYPE .EQ. 2) then
            x_a = x0 - 8*sigma
            x_b = x0 + 8*sigma
        else if (FUN_TYPE .EQ. 3) then
            x_a = x0 - 0.5
            x_b = x0 + 0.5
        end if

        kernelValue2 = Integrate(x_a, x_b, p, q) &
        + DCMPLX(0, 0.25D0/PI) * stepFunction(0.0D0) * (p + q) * DCMPLX(0, 2*ALPHA)/(DCMPLX(q, -ALPHA)* DCMPLX(p, ALPHA))
        return
    end function

    function IntegrandReal(x)
        real (kind = 8) x, k1, k2, IntegrandReal

        k1 = kernel_p
        k2 = kernel_q

        IntegrandReal = stepFunction(x) * DREAL(currentKernel(x, k1, k2))
        return
    end function

    function IntegrandImag(x)
        real (kind = 8) x, k1, k2, IntegrandImag

        k1 = kernel_p
        k2 = kernel_q

        IntegrandImag = stepFunction(x) * DIMAG(currentKernel(x, k1, k2))
        return
    end function

    function Integrate(x_a, x_b, p, q)
        real ( kind = 8 ) x_a, x_b, p, q, realPart, imagPart

        integer ( kind = 4 ), parameter :: limit = 5000
        integer ( kind = 4 ), parameter :: lenw = 4 * limit
        real ( kind = 8 ) abserr
        real ( kind = 8 ), parameter :: epsabs = 1.0D-12
        real ( kind = 8 ), parameter :: epsrel = 1.0D-16
        integer ( kind = 4 ) ier
        integer ( kind = 4 ), parameter :: key = 6
        integer ( kind = 4 ) last
        integer ( kind = 4 ) neval

        integer ( kind = 4 ), parameter :: npts2 = 3
        real (kind = 8), dimension(npts2) :: points, pts
        integer (kind = 4), dimension(npts2) :: ndin

        real (kind = 8), dimension(limit) :: alist, blist, rlist, elist
        integer (kind = 4), dimension(limit) :: level, iord

        complex (kind = 8) Integrate

        kernel_p = p
        kernel_q = q

        if(x_a * x_b <= 0) then
            points(1) = 0

            call dqagpe (IntegrandReal, x_a, x_b, npts2, points, epsabs, epsrel, limit, realPart, abserr, neval, ier, &
            alist,blist,rlist,elist,pts,iord,level,ndin,last)

            call dqagpe (IntegrandImag, x_a, x_b, npts2, points, epsabs, epsrel, limit, imagPart, abserr, neval, ier, &
            alist,blist,rlist,elist,pts,iord,level,ndin,last)
        else
            call dqagpe (IntegrandReal, x_a, x_b, 2, points, epsabs, epsrel, limit, realPart, abserr, neval, ier, &
            alist,blist,rlist,elist,pts,iord,level,ndin,last)

            call dqagpe (IntegrandImag, x_a, x_b, 2, points, epsabs, epsrel, limit, imagPart, abserr, neval, ier, &
            alist,blist,rlist,elist,pts,iord,level,ndin,last)
        end if

        Integrate = DCMPLX(realPart, imagPart)
        return
    end function

    ! -------------------------------
    ! GNUPLOT ROUTINE
    ! -------------------------------

    subroutine GeneratePlotFile(gpltfile, datafile, plotfile, X_LOW, X_HIGH)
        character(255) :: gpltfile, datafile, plotfile
        real(kind = 8)  :: X_LOW, X_HIGH
!fixing if creating two different pdfs
!character(255) :: gpltfile2, datafile2, plotfile2
!fixing end
        open(3, file = gpltfile, status = 'new')

        write(3,'(a)') "set encoding utf8"
        write(3,'(a)') "set terminal pdf size 6.0, 4.0 enhanced"
        write(3,'(a)') "set output '"//trim(plotfile)//"'"
        write(3,'(a)') "set datafile separator ';'"
        write(3,'(a)') ""
        write(3,'(a)', advance = "no") "set title 'Backflow in jump defect: "
        write(3,'(a, i0, a, i0, a, F0.2)') "N = ", int(N), ", P_{cutoff} = ", int(P_CUTOFF), ", |α| = ", abs(ALPHA)
        write(3,'(a)') "set style line 1 linecolor rgb 'red' linewidth 2"
        write(3,'(a)') "set style line 2 linecolor rgb 'blue' linewidth 2"
        write(3,'(a)') "set style line 3 linecolor rgb 'orange' linewidth 2"
!
       write(3,'(a)') "set style line 4 linecolor rgb 'forest-green' linewidth 2"
!
        write(3,'(a)') ""
        write(3,'(a)') "set label ''"
        write(3,'(a)') "set xlabel 'x_{0}'"
        write(3,'(a)') "set ylabel 'β_V(f)'"
        write(3,'(a)') "set key center right"
        write(3,'(a)') ""
        write(3,'(a, f6.2, a, f6.2, a)') "set xrange [", X_LOW, ":", X_HIGH, "]"
        write(3,'(a)') "set yrange [*:0]"
        write(3,'(a)') ""
       !write(3,'(a)') "plot '"//trim(datafile)//"' using 1:2 with lines ls 1 title 'α < 0', \"
       !write(3,'(a)') "     '"//trim(datafile)//"' using 1:3 with lines ls 2 title 'α > 0'"
    !original is above and the attempt changing below
        write(3,'(a)') "plot '"//trim(datafile)//"' using 1:2 with lines ls 1 title 'α < 0', \"
        write(3,'(a)') "     '"//trim(datafile)//"' using 1:3 with lines ls 2 title 'α > 0', \"
        write(3,'(a)') "     '"//trim(datafile)//"' using 1:4 with lines ls 3 title 'α < 0', \"
        write(3,'(a)') "     '"//trim(datafile)//"' using 1:5 with lines ls 4 title 'α > 0'"

        close(3)
!fixing
!open(3, file = gpltfile2, status = 'new')

!write(3,'(a)') "set encoding utf8"
!write(3,'(a)') "set terminal pdf size 6.0, 4.0 enhanced"
!write(3,'(a)') "set output '"//trim(plotfile2)//"'"
!write(3,'(a)') "set datafile separator ';'"
!write(3,'(a)') ""
!write(3,'(a)', advance = "no") "set title 'Backflow in jump defect: "
!write(3,'(a, i0, a, i0, a, F0.2)') "N = ", int(N), ", P_{cutoff} = ", int(P_CUTOFF), ", |α| = ", abs(ALPHA)
!write(3,'(a)') "set style line 1 linecolor rgb 'red' linewidth 2"
!write(3,'(a)') "set style line 2 linecolor rgb 'blue' linewidth 2"
!write(3,'(a)') "set style line 3 linecolor rgb 'forest-green' linewidth 2"
!write(3,'(a)') ""
!write(3,'(a)') "set label ''"
!write(3,'(a)') "set xlabel 'x_{0}'"
!write(3,'(a)') "set ylabel 'β_V(f)'"
!write(3,'(a)') "set key center right"
!write(3,'(a)') ""
!write(3,'(a, f6.2, a, f6.2, a)') "set xrange [", X_LOW, ":", X_HIGH, "]"
!write(3,'(a)') "set yrange [*:0]"
!write(3,'(a)') "plot '"//trim(datafile2)//"' using 1:2 with lines ls 1 title 'α < 0', \"
!write(3,'(a)') "     '"//trim(datafile2)//"' using 1:3 with lines ls 2 title 'α > 0'"

!close(3)

!fixing

    end subroutine
end module


!********************************************************************************
!   RAND_UNITY: Compare FPML against Polzers and AMVW on polynomials with
!   random complex roots in the unit circle.
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 11 Novemeber 2018
!********************************************************************************
! The speed and accuracy of FPML is compared against Polzeros and AMVW for
! computing the roots of a polynomial with random roots in the unit circle.
!********************************************************************************
program rand_unity
    use fpml
    use poly_zeroes
    use mpmodule
    implicit none
    ! read in variables
    character(len=32)                           :: arg
    integer                                     :: flag, startDegree, endDegree, itnum
    ! testing variables
    integer                                     :: deg, it, j, clock_rate, clock_start, clock_stop
    real(kind=dp), dimension(:), allocatable    :: coeffs, err, xr, xi
    real(kind=dp), dimension(:,:), allocatable  :: results
    complex(kind=dp), dimension(:), allocatable :: exact_roots
    ! FPML variables
    integer, parameter                          :: nitmax=35
    integer, dimension(:), allocatable          :: conv
    real(kind=dp), dimension(:), allocatable    :: berr, cond
    complex(kind=dp), dimension(:), allocatable :: p, roots
    ! Polzeros variables
    integer                                     :: iter
    logical, dimension(:), allocatable          :: h
    real(kind=dp), dimension(:), allocatable    :: radius
    complex(kind=dp), dimension(:), allocatable :: zeros
    ! AMVW variables
    real(kind=dp), dimension(:), allocatable    :: residuals
    complex(kind=dp), dimension(:), allocatable :: poly, eigs

    call mpinit

    ! read in optional arguments
    call get_command_argument(1,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') startDegree
    else
        startDegree=10
    end if
    call get_command_argument(2,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') endDegree
    else
        endDegree=100
    end if
    call get_command_argument(3,arg,status=flag)
    if(flag==0) then
        read(arg, '(I10)') itnum
    else
        itnum=512
    end if

    ! Testing: polynomial with random unitary complex roots in the unit circle
    call init_random_seed()
    open(unit=1,file="data_files/rand_unity.dat")
    write(1,'(A)') 'Degree, FPML_time, FPML_err, Polzeros_time, Polzeros_err, AMVW_time, AMVW_err'
    allocate(results(itnum,6))
    deg=startDegree
    do while(deg<=endDegree)
        write(1,'(I10)', advance='no') deg
        write(1,'(A)', advance='no') ','
        allocate(exact_roots(deg), coeffs(deg), err(deg), xr(deg), xi(deg))
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
        allocate(zeros(deg), radius(deg), h(deg+1))
        allocate(poly(deg+1), eigs(deg), residuals(deg))
        do it=1,itnum
            ! roots
            call rand_unitcmplx(exact_roots,deg)
            xr = dble(exact_roots)
            xi = aimag(exact_roots)
            ! polynomial
            call rootstocoeffs(deg,xr,xi,coeffs)
            p(1:deg) = (/ (cmplx(coeffs(j),0,kind=dp), j=1,deg)/)
            p(deg+1) = cmplx(1,0,kind=dp)
            poly = (/ (p(deg-j+1), j=0,deg)/)
            ! FPML
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main(p, deg, roots, berr, cond, conv, nitmax)
            call system_clock(count=clock_stop)
            results(it,1) = dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,2) = maxval(berr)
            ! Polzeros
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call polzeros(deg, p, eps, big, small, nitmax, zeros, radius, h, iter)
            call system_clock(count=clock_stop)
            results(it,3)=dble(clock_stop-clock_start)/dble(clock_rate)
            call error(p, zeros, err, deg)
            results(it,4)=maxval(err)
            ! AMVW
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call z_poly_roots(deg, poly, eigs, residuals, flag)
            call system_clock(count=clock_stop)
            results(it,5)=dble(clock_stop-clock_start)/dble(clock_rate)
            call error(p, eigs, err, deg)
            results(it,6)=maxval(err)
        end do
        deallocate(exact_roots, coeffs, err, xr, xi, p, roots, berr, cond, conv, zeros, radius, h, poly, eigs, residuals)
        ! write results to file
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,1))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,2))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,3))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,4))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') sum(results(1:itnum,5))/itnum
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)') sum(results(1:itnum,6))/itnum
        ! update deg
        deg=deg+2
    end do
    deallocate(results)
    ! close file
    close(1)
contains
    !************************************************
    !                   init_random_seed            *
    !************************************************
    ! Initiate random seed using system_clock. This
    ! seed is then available for the random number
    ! generator in random_number for the life of
    ! the program.
    !************************************************
    subroutine init_random_seed()
        implicit none
        ! local variables
        integer                             :: i, n , clock
        integer, dimension(:), allocatable  :: seed
        ! intrinsic subroutines
        intrinsic                           :: random_seed, system_clock

        ! main
        call random_seed(size = n)
        allocate(seed(n))

        call system_clock(count = clock)
        seed = clock + 37 * (/ (i - 1, i = 1,n) /)
        call random_seed(put = seed)

        deallocate(seed)
    end subroutine init_random_seed
    !************************************************
    !                   error                       *
    !************************************************
    ! Computes the relative backward error for
    ! each root approximation of p.
    !************************************************
    subroutine error(p, roots, err, deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        real(kind=dp), intent(out)      :: err(:)
        complex(kind=dp), intent(in)    :: p(:), roots(:)
        ! local variables
        integer                         :: j, k
        real(kind=dp)                   :: r, berr
        real(kind=dp), dimension(deg+1) :: alpha
        complex(kind=dp)                :: a, z

        ! main
        alpha = abs(p)
        alpha = (/ (alpha(j)*(3.8*(j-1)+1),j=1,deg+1)/)
        do j=1,deg
            z = roots(j)
            r = abs(z)
            if(r>1) then
                z = 1/z
                r = 1/r
                a = p(1)
                berr = alpha(1)
                do k=2,deg+1
                    a = z*a + p(k)
                    berr = r*berr + alpha(k)
                end do
            else
                a = p(deg+1)
                berr = alpha(deg+1)
                do k=deg,1,-1
                    a = z*a + p(k)
                    berr = r*berr + alpha(k)
                end do
            end if
            err(j) = abs(a)/berr
        end do
    end subroutine error
    !************************************************
    !                       rand_unitcmplx          *
    !************************************************
    ! creates a random array of unitary complex numbers.
    ! Complex numbers come in conjugate pairs, thus
    ! array should have size divisible by 2.
    !************************************************
    subroutine rand_unitcmplx(array,size)
        implicit none
        ! argument variables
        integer, intent(in)             :: size
        complex(kind=dp), intent(out)   :: array(:)
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: theta1, theta2, r
        real(kind=dp), parameter        :: pi = 3.141592653589793d0

        ! main
        do k=1,size,2
            call random_number(theta1)
            call random_number(theta2)
            call random_number(r)
            theta1 = -1 + 2*theta1
            theta2 = -1 + 2*theta2
            array(k) = r*cmplx(cos(theta1*pi),sin(theta2*pi),kind=dp)
            array(k+1) = conjg(array(k))
        end do
    end subroutine rand_unitcmplx
end program rand_unity


      program siterativeEof
      use ufileformat
c---------------------------------------------------------------------c
c     "iterativeEOF", Version 2.0, December, 2002.                    c
c      A Krylov-based code for computing EOF                          c
c      Vincent TOUMAZOU                                               c
c      Vincent.Toumazou@cnes.fr                                       c
c      CNES/MERCATOR-Ocean                                            c
c      18, Avenue Edouard Belin                                       c
c      F-31401 TOULOUSE Cedex 4                                       c
c      URL: http://www.mercator.com.fr                                c
c      URL: http://www.cnes.fr                                        c
c---------------------------------------------------------------------c

c$$$       interface
c$$$       subroutine readMatrix(fname,matrix,imax,jmax)
c$$$       character(len=*),intent(in) :: fname
c$$$       real,intent(out) :: matrix(:,:)
c$$$       integer,intent(out) :: imax,jmax
c$$$       end interface

      integer          maxm, maxn, maxnev, maxncv, ldv, ldu
      parameter       (maxm = 40000, maxn=250, maxnev=20, maxncv=25,
     &                 ldu = maxm, ldv=maxn, nlines=22)
      Real
     &                 meanA(maxm),
     &                 w(ldu), v(ldv,maxncv), u(ldu, maxnev),
     &                 workl(maxncv*(maxncv+8)), workd(3*maxn),
     &                 s(maxncv,2), resid(maxn),
     &                 tol, t, sumSV

      real, pointer :: A(:,:)
      logical          select(maxncv)
      integer          M, N, nev, ncv
      character*72     comment
      character(len=50) list(22)

c
c

      write(*,*) '********************************************'
      write(*,*) '**********  starting program  **************'
      write(*,*) '********************************************'

c
c     Numerical parameters
c
      open(1,file='Input/numerical.data')
      read(1,500) comment
      read(1,500) comment
      read(1,500) comment
      read(1,500) comment
      read(1,500) comment
      read(1,*) nev
      read(1,500) comment
      read(1,500) comment
      read(1,*) ncv
      read(1,500) comment
      read(1,500) comment
      read(1,*) tol
      close(1)
      write(*,*) '***'
      write(*,*) 'Numerical data read'
      write(*,*) 'Number of required modes         = ', nev
      write(*,*) 'Size of projection               = ', ncv
      write(*,*) 'Treshold for Lanczos convergence = ', tol
      write(*,*) '***'
c
c   Reads the matrix of data
c

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  CAUTION : Call your subroutine for reading     C
C            the matrix of data.                  C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C     call readMatrix
C    &     (Add your parameters here, A, m and n
C    &      must be the outputs of your subroutine
C    &      and maxm, maxn the leading dimension of A
C    &      have to be in the inputs of the subroutine)
C Example : call readMatrix(A, maxm, maxn, m, n)

      open(77,file = '/u/alvera/Datafiles/Analist/analistTEM.dat')

      do i=1,nlines
      read(77,'(a50)') list(i)
      end do

      call readMatrix(list,A, M, N)

      write(*,*) '***'
      write(*,*) 'Matrix loaded'
      write(*,*) 'Size of the matrix = ', m,' by ', n
      write(*,*) '***'

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C  CAUTION : Uncomment the 2 next calls if you    C
C            want to center your data with the    C
C            mean on each point with respect      C
C            to the total period.                 C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c
c    Computes the Row-means of the matrix
c
      call smeanByRow
     &     (A, m, n, meanA, maxm, maxn)

c
c    Transforms the matrix such that its raws have a zero mean
c
      call smeanToZero
     &     (A, m, n, meanA, maxm, maxn)

c
c    Estimates the total variance
c
      call svariExp
     &     (A, m, n, maxm, maxn, sumSV, w)

c
c   Computes the NEV singular values and the modes of interest
c

      write(*,*) '********************************************'
      write(*,*) '*****  Starting the Lanczos Process  *******'
      write(*,*) '********************************************'

      call ssvd_lancz
     &       (A, m, n, maxm, maxn, nev, ncv, maxnev, maxncv, ldv,
     &        ldu, w, v, u, workl, workd, s, resid, select, tol)

      write(*,*) '********************************************'
      write(*,*) '*******  End of the Lanczos Process  *******'
      write(*,*) '********************************************'

c
c Uncomment the next call if you want to normalize your outputs
c
c     call snormal_output
c    &        (s, u, v, m, n, nev, maxncv, ldu, ldv,
c    &         maxnev, maxm)

c
c   Extracts singular values and associated modes, prepares the
c   output file for graphical exploitation.
c

c
c   Singular values
c   _______________
      open(1,file='Output/outputEof.vlsng')
      do i=nev,1,-1
         write(1,501) s(i,1)
      enddo
      close(1)
c
c   Variance detailed
c   _______________
      open(1,file='Output/outputEof.varEx')
      do i=nev,1,-1
         write(1,504) 'Mode ', nev+1-i, ' = ',
     &               100.0*s(i,1)*s(i,1)/sumSV, ' %'
      enddo
      close(1)

c
c   Spatial modes
c   _______________
      open(1,file='Output/outputEof.lftvec')
      do j=1,m
         write(1,503) (u(j,i),i=nev,1,-1)
      enddo
      close(1)
c
c   Temporal modes
c   _______________
      open(1,file='Output/outputEof.rghvec')
      do j=1,n
         write(1,503) (v(j,i),i=nev,1,-1)
      enddo
      close(1)
      close(77)
 500  format(a72)
 501  format(e10.4)
 502  format(3e10.4)
 503  format(300(e10.4,1X))
 504  format(a5,i3,a3,f8.4,a2)
      end


module positions
    use types
    use box_pot_parameters, only: np, sqtwodt, boxl, deltat
    use randomm

    implicit none
    private

    public position, position_ih

contains

    subroutine position_ih(rpos, f, dij, Rz, pbc)
        real(dp), intent(in) :: f(:, :)
        real(dp), intent(inout) :: rpos(:, :)
        real(dp), intent(in) :: dij(:, :)
        real(dp), intent(in) :: Rz(:)
        logical, intent(in):: pbc
        ! Local variables
        integer :: i, j, ij
        integer, parameter :: k = 3 ! Dimensión espacial del sistema
        real(dp) :: temp(np*k)
        real(dp) :: mulout(k)

        temp = 0.0_dp

        do i = 1, k*np, k
            do j = 1, np - 1
                ij = (k*j) - k + 1
                call dgemv('n', k, k, 1.0_dp, dij(i:i + 2, ij:ij + 2), &
                        k, f(:, j), 1, 0.0_dp, mulout, 1)
                temp(i:i + 2) = temp(i:i + 2) + mulout
            end do
        end do

        do i = 1, np
            ij = (k*i) - k + 1
            rpos(1, i) = rpos(1, i) + temp(ij)*deltat + sqtwodt*Rz(ij)
            rpos(2, i) = rpos(2, i) + temp(ij + 1)*deltat + sqtwodt*Rz(ij + 1)
            rpos(3, i) = rpos(3, i) + temp(ij + 2)*deltat + sqtwodt*Rz(ij + 2)
            if (pbc) then
                rpos(:, i) = rpos(:, i) - boxl*dnint(rpos(:, i)/boxl)
            end if
        end do
    end subroutine position_ih

    subroutine position(r, f, pbc)
        real(dp), intent(in) :: f(:, :)
        real(dp), intent(inout) :: r(:, :)
        logical, intent(in):: pbc
        ! Local variables
        integer :: i, j
        integer, parameter :: n = 3 ! Dimensiones espaciales
        real(dp) :: std_rand(n, np)

        ! Distribución normal con desviación estándar igual a sqrt(2*\Delta t)
        do i = 1, n
            do j = 1, np
                std_rand(i, j) = gasdev() * sqtwodt
            end do
        end do

        do i = 1, np
            r(:, i) = r(:, i) + ( f(:, i)*deltat ) + std_rand(:, i)
            if (pbc) then
                r(:, i) = r(:, i) - boxl*dnint(r(:, i)/boxl)
            end if
        end do

    end subroutine position
end module positions


C++******************************************************************
C NORMALIZE1
C
C To normalize one image to a similar image, determining the
C scale and zero difference between the two images by plotting
C the intensities in the two images against each other.
C
C JLP
C Version 10-04-90
C--******************************************************************
	PROGRAM NORMALIZE1
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*method
*       obtain input images and extract descriptor items. call pchist
*       to implement an auto-scaling function to determine a range of
*       data values to plot. obtain necessary parameters from the
*       environment. call nmplot to normalise the two images.
*
*starlink parameters
*       aimage
*              input image to normalize to
*       bimage
*              input image to be normalized
*       ilevel
*              interaction level...controls printing of results
*       pcrange
*              lower and upper histogram points (in percent) defining
*              the default (auto-scaled) data range used in image a
*       arange
*              lower and upper range of data values in image a, used
*              to override the autoscaling
*       nbin
*              number of bins to use in binning the scatter plot prior
*              to fitting a straight line
*       niter
*              number of iterations to reject bad data values
*       nsigma
*              number of standard deviations at which bad data is
*              rejected
*       minpix
*              minimum number of good pixels required in a bin before
*              it contributes to the fitted line
*       device
*              graphics device on which to plot the fitted line
*       e
*              output parameter giving the slope in the expression
*              b=e*a+c
*       c      output parameter giving the constant c in the
*              above expression
*
*calls
*              pchist,nmplot
*
*written by
*       r.f. warren-smith
*-----------------------------------------------------------------------
*
* NBINS for the histogram:
	PARAMETER(NBINS=10000)
	CHARACTER CVAL*1,PLOTDEV*32,NAMEA*40,NAMEB*40
	CHARACTER COMMENTSA*80,COMMENTSB*80,OPTIONS*200
	REAL*4 MMM,CCC,NSIGMA,PCRANGE(2),ARANGE(2)
	REAL*4 INVALA,INVALB
	INTEGER*4 MADRID(1)
	INTEGER*4 IHIST(NBINS),IPA,IPB,IP1,IP2,IP3,IP4,IP5
	COMMON /VMR/MADRID

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

	WRITE(6,27)
27	FORMAT(' Program NORMALIZE1,  Version 10-04-90',/,
     1	' To compute the linear transformation between the'
     1	' intensities of two images')

* Obtain user interaction level
	ILEVEL=2
*
* Obtain first input image
	WRITE(6,*) ' First image:'
	NAMEA=' '
	CALL JLP_VM_READIMAG(IPA,NPIXA,NLINEA,NAMEA,
     1	COMMENTSA)

*
* Obtain second input image
	WRITE(6,*) ' Second image:'
	NAMEB=' '
	CALL JLP_VM_READIMAG(IPB,NPIXB,NLINEB,NAMEB,
     1	COMMENTSB)
	INVALA=-32000.
	INVALB=INVALA

* call pchist to auto scale, giving the default data range to use
* for image a
*
	CALL PCMINMAX(MADRID(IPA),NPIXA,NLINEA,INVALA,XMIN,XMAX)
	WRITE(6,55) XMIN,XMAX
55	FORMAT(' Min, max for image 1:',2(G12.5,X))
	IF (XMIN.EQ.XMAX) THEN
	  WRITE(6,*) ' Fatal error: same value for the whole image 1'
	  GO TO 99
	ENDIF

* Obtain percentage histogram range for scaling the binning of
* image a
* (Between 0. and 1.)
	PCRANGE(1)=0.05
	PCRANGE(2)=0.95
	WRITE(6,56) PCRANGE(1),PCRANGE(2)
56	FORMAT(' We take the histogram between ',F5.2,' and',F5.2,
     1	' %')

	CALL PCHIST1(MADRID(IPA),NPIXA,NLINEA,INVALA,PCRANGE,ARANGE,
     1	IHIST,NBINS,XMIN,XMAX,IERR)

*
* if the image has no valid pixels, abort with error message
	IF (IERR.NE.0) THEN
	  WRITE(6,*) ' Fatal error: no valid pixels'
	  GO TO 99
	ENDIF

	WRITE(6,57) ARANGE(1),ARANGE(2)
57	FORMAT(' Which correspond to ',G12.5,' and',G12.5,
     1	' in real values')
*
* obtain number of bins for binning the scatter plot
	NBIN=50
*
* obtain the number of data rejection iterations
	NITER=2
*
* obtain rejection threshold
	NSIGMA=3.0
*
* obtain the minimum number of pixels required per bin
	MINPIX=5
*
* obtain plotting device
	WRITE(6,24)
24	FORMAT(' Output graphic device ?')
	READ(5,10) PLOTDEV
10	FORMAT(A)

*
* Obtain workspace
	I4=NBIN*4
	I8=NBIN*8
	CALL JLP_GETVM(IP1,I4)
	CALL JLP_GETVM(IP2,I4)
	CALL JLP_GETVM(IP3,I4)
	CALL JLP_GETVM(IP4,I8)
	CALL JLP_GETVM(IP5,I4)
*
* Call nmplot to perform normalization of image b to image a
*
	CALL NMPLOT(MADRID(IPA),NPIXA,NLINEA,INVALA,
     1	MADRID(IPB),NPIXB,NLINEB,INVALB,ILEVEL,ARANGE(1),
     1	ARANGE(2),NBIN,NITER,NSIGMA,MINPIX,PLOTDEV,MMM,CCC,IERRN,
     1	MADRID(IP1),MADRID(IP2),MADRID(IP3),MADRID(IP4),MADRID(IP5),
     1	NAMEA,NAMEB)

	IF (IERRN.NE.0) THEN
* if no fit was obtained, quit with error message
	  WRITE(6,22) IERRN
22	  FORMAT(' Fatal error in NMPLOT: fit has failed, IERRN= ',I3)
	ELSE
* Write fit parameters to environment:
* b=e*a+c
	  WRITE(6,23) MMM,CCC
23	  FORMAT(' Ratio image2/image1 RATIO21 =',G12.5,/,
     1	' Offset 2 - 1, OFF21 =',G12.5,/,
     1	' That is : image2_normalized = (image2-OFF21)/RATIO21 '/,
     1	' OR        image2 = image1 * RATIO21 + OFF21')
	ENDIF

99	CALL JLP_END
	STOP
	END

C*********************************************************************
C PCMINMAX
C Computes min/max:
C*********************************************************************
	SUBROUTINE PCMINMAX(IA,NPIX,NLINES,INVAL,XMIN,XMAX)
	REAL*4 IA(NPIX*NLINES),XMIN,XMAX,INVAL,WORK
	NN=NPIX*NLINES
	XMIN=IA(1)
	XMAX=IA(1)
	  DO 5 I=1,NN
	    WORK=IA(I)
	    IF(WORK.NE.INVAL)THEN
	      XMIN=MIN(XMIN,WORK)
	      XMAX=MAX(XMAX,WORK)
	    ENDIF
5	  CONTINUE

	RETURN
	END

	SUBROUTINE PCHIST1(IA,NPIX,NLINES,INVAL,PCRANGE,ARANGE,
     1	IHIST,NBINS,XMIN,XMAX,IERR)
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*purpose
*       to find the integer value in an image corresponding to a
*       specific fraction of the image histogram from 0.0 to 1.0
*
*method
*       form a histogram of the image integers and scan up or down to
*       find the appropriate point
*
*arguments
*       ia (in)
*       real*4(npix*nlines)
*               the input image
*       npix,nlines (in)
*       integer
*               dimensions of ia
*       inval (in)
*       real
*               invalid pixel flag for ia
*       pcrange (in)
*       real(2)
*               array of fractional positions in the histogram in the
*               range 0.0 to 1.0
*       ihist (workspace)
*       integer(nbins)
*               used to hold the image histogram. contains histogram
*               on exit
*
*written by
*       r.f. warren-smith
*-----------------------------------------------------------------------
*
	REAL*4 IA(NPIX*NLINES),INVAL
	INTEGER*4 IHIST(NBINS)
	REAL*4 PCRANGE(2),XMIN,XMAX,ARANGE(2)

*
* initiallise histogram
*
	IERR=0

	DO 1 I=1,NBINS
	  IHIST(I)=0
1	CONTINUE

	STEP=(XMAX-XMIN)/FLOAT(NBINS-1)
*
* form a histogram of all the valid pixels
*
	NPTS=0
	NN=NPIX*NLINES
	DO 2 I=1,NN
         IF(IA(I).NE.INVAL) THEN
	   WORK=(IA(I)-XMIN)/STEP
           INTGR=NINT(WORK)+1
           IHIST(INTGR)=IHIST(INTGR)+1
           NPTS=NPTS+1
         ENDIF
2	CONTINUE

*
* if there are no valid pixels, exit with error flag set
      IF(NPTS.EQ.0) THEN
         IERR=1
         GO TO 99
      ENDIF

* Consider each percentage histogram point
*
      DO 4 I=1,2

* Calculate the number of data points corresponding to this point
* counting up or down depending on which side of the median
*
         IF(PCRANGE(I).LE.0.5) THEN
            LIMIT=NINT(NPTS*PCRANGE(I))
            ISTART=1
            IEND=NBINS
            IDIRN=1
         ELSE
            LIMIT=NINT(NPTS*(1.0-PCRANGE(I)))
            ISTART=NBINS
            IEND=1
            IDIRN=-1
         ENDIF

         IF(LIMIT.EQ.0) LIMIT=1
*
* Count through histogram to find this point
*
         N=0

         DO 3 J=ISTART,IEND,IDIRN
            N=N+IHIST(J)
            IF(N.GE.LIMIT) GO TO 8
3        CONTINUE

8        ARANGE(I)=J*STEP+XMIN
4     CONTINUE

99    RETURN

      END

	SUBROUTINE NMPLOT(IA,NPIXA,NLINEA,INVALA,IB,NPIXB,
     1	NLINEB,INVALB,ILEVEL,AMIN,AMAX,NBIN,NITER,NSIGMA,
     1	MINPIX,PLOTDEV,MMM,CCC,IERR,NSUM,ASUM,BSUM,B2SUM,VARLIM,
     1	NAMEA,NAMEB)
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*Purpose
*       to normalize one image to another similar image by plotting
*       the intensities in each image against each other
*
*Method
*       Intensities which are valid in each input image and lie within
*       the data range to be used in image A are binned according to
*       the intensity in image A. A mean and standard deviation for the
*       B intensities are found for each bin. A straight line is fitted
*       to this binned data to determine the slope and intercept, from
*       which the B image may be normalized to the A image. Iterations
*       are performed to reject bad data by repeating the binning and
*       line fitting procedure, rejecting pixels whose B intensities
*       deviate by more than a specified number of standard deviations
*       from the line fitted in the previous iteration.
*
*Arguments
*       ia (in)
*       integer*2(npixa,nlinea)
*              first input image to be normalized to
*       npixa,nlinea (in)
*       integer
*              dimensions of image ia
*       invala (in)
*       real
*              invalid pixel flag for ia
*       ib (in)
*       integer*2(npixb,nlineb)
*              second input image...the one to be normalized
*       npixb,nlineb (in)
*       integer
*              dimensions of ib
*       invalb (in)
*       real
*              invalid pixel flag for ib
*       ilevel (in)
*       integer
*              interaction level...controls printing of results
*       amin,amax (in)
*       real
*              the range of data values to use in image a
*       nbin (in)
*       integer
*              the number of bins to use for the data
*       niter (in)
*       integer
*              number of data rejection iterations to use
*       NSIGMA (in)
*       real
*              rejection threshold in standard deviations for aberrant
*              data values
*       minpix (in)
*       integer
*              min. number of data values required before a bin is used
*       mmm (out)
*       real
*              slope of line fitted in the expression b=m*a+c
*       ccc (out)
*       real
*              constant c in the above expression
*       ierr (out)
*       integer
*              error flag: zero for success
*       nsum (work)
*       integer(nbin)
*              workspace
*       asum,bsum (work)
*       real(nbin)
*              workspace
*       b2sum (work)
*       double precision(nbin)
*              workspace
*       varlim (work)
*       real(nbin)
*              workspace
*
*notes
*       uses integer*2 arrays and subroutine names with more than
*       six characters
*
*written by
*       r.f. warren-smith
*-----------------------------------------------------------------------
*
	REAL*4 IA(NPIXA,NLINEA),IB(NPIXB,NLINEB)
	INTEGER*4 NSUM(NBIN)
	CHARACTER PLOTDEV*32,CHAR1*30,CHAR2*30,TITLE*40,NCHAR*4
	CHARACTER NAMEA*40,NAMEB*40,PCOLOR*30
	REAL*4 MMM,CCC,VARLIM(NBIN),ASUM(NBIN),BSUM(NBIN),RESID
	REAL*8 XSUM,X2SUM,YSUM,XYSUM,WTSUM,B2SUM(NBIN),X,Y,WT,
     1	ATOP,ABOT
	REAL*4 INVALA,INVALB

	IERR=0

*
* Set minimum expected variance for a bin
*
      Q0=0.5
      MMM=1.0
      CCC=0.0

*
* Set constants to convert intensity into bins
*
      AAMIN=MIN(AMIN,AMAX)
      AAMAX=MAX(AMIN,AMAX)
      A0=1.5-AAMIN*(NBIN-1)/MAX(1.0E-20,AAMAX-AAMIN)
      A1=(NBIN-1)/MAX(1.0E-20,AAMAX-AAMIN)

*
* initiallise the variance threshold for each bin
*

      DO 1 I=1,NBIN
         VARLIM(I)=1.0E20
1     CONTINUE

*
* perform niter iterations
*
      ITER=1

37    IF(ITER.LE.NITER)THEN

*
* initiallise the bins
*

         DO 2 I=1,NBIN
            NSUM(I)=0
            ASUM(I)=0.0
            BSUM(I)=0.0
            B2SUM(I)=0.0D0
2        CONTINUE

*
* scan the area common to both images
*

         DO 99 J=1,MIN(NLINEA,NLINEB)

            DO 98 I=1,MIN(NPIXA,NPIXB)

*
* use pixels which are ok on both images
*

               IF(IA(I,J).NE.INVALA.AND.IB(I,J).NE.INVALB) THEN

*
* check if the a intensity is in the required data range
*
                  A=IA(I,J)
                  IF(A.GE.AAMIN.AND.A.LE.AAMAX) THEN

*
* calculate the bin number and form sums for this bin
*
                     IBIN=NINT(A0+A1*A)
                     B=IB(I,J)
 		     RESID=(B-A*MMM-CCC)**2
                     IF(RESID.LE.VARLIM(IBIN))THEN
                        NSUM(IBIN)=NSUM(IBIN)+1
                        BSUM(IBIN)=BSUM(IBIN)+B
                        B2SUM(IBIN)=B2SUM(IBIN)+B*B
                        ASUM(IBIN)=ASUM(IBIN)+A
                     ENDIF

                  ENDIF

               ENDIF

98          CONTINUE

99       CONTINUE

*
* count the total number of pixels used
*
         NPIX=0

         DO 3 I=1,NBIN
            NPIX=NPIX+NSUM(I)
3        CONTINUE

	WRITE(6,47) NPIX
47	FORMAT(' Total number of pixels used:',I7)

* calculate the max. weight to be applied to any bin (this is the number
* of points per bin if the points are uniformly distributed)
*
         WTMAX=REAL(NPIX)/REAL(NBIN)

* initiallise sums for the straight line fit
*
         XSUM=0.0D0
         X2SUM=0.0D0
         YSUM=0.0D0
         XYSUM=0.0D0
         WTSUM=0.0D0
         ABOT=1.0D20
         ATOP=-1.0D20

*
* scan those bins with at least the minimum number of pixels in
*

         DO 4 I=1,NBIN

            IF(NSUM(I).GE.MINPIX) THEN

*
* form the weight for this bin
*
               WT=MIN(WTMAX,REAL(NSUM(I)))

*
* set the variance threshold in this bin for the next iteration
*
               VARLIM(I)=(NSIGMA**2)*(B2SUM(I)-(BSUM(I)**2)/NSUM(I))
     :          /NSUM(I)
               VARLIM(I)=MAX(VARLIM(I),Q0*(NSIGMA**2))

*
* Form the mean data values in each bin
*
               X=ASUM(I)/NSUM(I)
               Y=BSUM(I)/NSUM(I)

*
* Form weighted sums for fit
*
               XSUM=XSUM+X*WT
               X2SUM=X2SUM+X*X*WT
               YSUM=YSUM+Y*WT
               XYSUM=XYSUM+Y*X*WT
               WTSUM=WTSUM+WT

*
* Note the range of values used
*
               ATOP=MAX(ATOP,X)
               ABOT=MIN(ABOT,X)

            ELSE

*
* Set minimum variance for bins with too few points
*
               VARLIM(I)=(NSIGMA**2)*Q0
            ENDIF

4        CONTINUE

*
* If normal equations are singular, abort with ierr=1
*
         DET=WTSUM*X2SUM-XSUM*XSUM

         IF(DET.EQ.0.0) THEN
            IERR=1
	    WRITE(6,*) ' Null DET in NMPLOT'
            GO TO 77
         ENDIF

*
* form the straight line parameters (B=MMM*A+CCC)
*
         MMM=(WTSUM*XYSUM-XSUM*YSUM)
         CCC=(X2SUM*YSUM-XSUM*XYSUM)
         MMM=MMM/DET
         CCC=CCC/DET

*
* if required, print the results of this iteration
*

         IF(ILEVEL.GE.2) THEN
            WRITE(6,14)ITER,NPIX,ABOT,ATOP
14          FORMAT('   Iteration ',I3,' used ',I10,' pixels from A=',
     1	G13.6,' to ',G13.6)
            WRITE(6,15)MMM,CCC
15          FORMAT('   Fit gives:   B=(',G13.6,')*A + (',G13.6,')')
         ENDIF

*
* on the final iteration, plot the fit if required
*

         IF(ITER.EQ.NITER) THEN

* remove bins with no data in and form the values to plot
*
            NDATA=0

            DO 16 I=1,NBIN

               IF(NSUM(I).GE.MINPIX) THEN
                  NDATA=NDATA+1
                  ASUM(NDATA)=ASUM(I)/NSUM(I)
                  BSUM(NDATA)=BSUM(I)/NSUM(I)
                  VARLIM(NDATA)=SQRT(MAX(0.0D0,(B2SUM(I)-(BSUM(I)**2)
     :             *NSUM(I))/NSUM(I)))
               ENDIF

16          CONTINUE

*
* Plot graph
*
	    NCHAR='43'
            PCOLOR='Default'
	    WRITE(CHAR1,42) NAMEA(1:12)
	    WRITE(CHAR2,42) NAMEB(1:12)
42	    FORMAT('Int. of',A12)
	    TITLE=' Normalization plot'
            ASUM(2)=ASUM(NDATA)
            BSUM(1)=MMM*ASUM(1)+CCC
            BSUM(2)=MMM*ASUM(2)+CCC
C            CALL HIGR_DRLINE(ASUM,BSUM,2)
	    CALL NEWPLOT(ASUM,BSUM,NDATA,NBIN,1,CHAR1,CHAR2,
     1	TITLE,NCHAR,PCOLOR,PLOTDEV,' ',' ')

         ENDIF

*
* Count iterations and return for next
*
         ITER=ITER+1
         GO TO 37

      ENDIF

77    RETURN
      END


      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
*
*  -- LAPACK routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*  -- Modified by Peter Soendergaard for ATLAS Fortran77 LAPACK interface,
*     2001
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION    A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  DTRTRI computes the inverse of an upper or lower triangular
*  matrix A.
*
*  This is the Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  A is upper triangular;
*          = 'L':  A is lower triangular.
*
*  DIAG    (input) CHARACTER*1
*          = 'N':  A is non-unit triangular;
*          = 'U':  A is unit triangular.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the triangular matrix A.  If UPLO = 'U', the
*          leading N-by-N upper triangular part of the array A contains
*          the upper triangular matrix, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading N-by-N lower triangular part of the array A contains
*          the lower triangular matrix, and the strictly upper
*          triangular part of A is not referenced.  If DIAG = 'U', the
*          diagonal elements of A are also not referenced and are
*          assumed to be 1.
*          On exit, the (triangular) inverse of the original matrix, in
*          the same storage format.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
*               matrix is singular and its inverse can not be computed.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER ATLASROWMAJOR, ATLASCOLMAJOR
      PARAMETER (ATLASROWMAJOR=101, ATLASCOLMAJOR=102)
      INTEGER ATLASNOTRANS, ATLASTRANS, ATLASCONJTRANS
      PARAMETER (ATLASNOTRANS=111, ATLASTRANS=112, ATLASCONJTRANS=113)
      INTEGER ATLASUPPER, ATLASLOWER
      PARAMETER (ATLASUPPER=121, ATLASLOWER=122)
      INTEGER ATLASNONUNIT, ATLASUNIT
      PARAMETER (ATLASNONUNIT=131, ATLASUNIT=132)
      INTEGER ATLASLEFT, ATLASRIGHT
      PARAMETER (ATLASLEFT=141, ATLASRIGHT=142)
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ATL_F77WRAP_DTRTRI
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DTRTRI', -INFO )
         RETURN
      END IF
*
      IF (UPPER) THEN
         IUPLO = ATLASUPPER
      ELSE
         IUPLO = ATLASLOWER
      ENDIF
*
      IF (NOUNIT) THEN
         IDIAG = ATLASNONUNIT
      ELSE
         IDIAG = ATLASUNIT
      ENDIF
*
      CALL ATL_F77WRAP_DTRTRI( IUPLO, IDIAG, N, A, LDA, INFO )
*
      RETURN
      END


module my_subs
implicit none
interface my_sum
  module procedure sum_real, sum_int
end interface my_sum
contains
    subroutine sum_real (array, tot)
       real, dimension(:), intent (in) :: array
       real, intent (out) :: tot
       integer :: i
       tot = 1.0
       do i=1, size (array)
          tot = tot * array (i)
       end do
    end subroutine sum_real

    subroutine sum_int (array, tot)
       integer, dimension(:), intent (in) :: array
       integer, intent (out) :: tot
       integer :: i
       tot = 0
       do i=1, size (array)
          tot = tot + array (i)
       end do
    end subroutine sum_int

end module my_subs

program test_dt
use my_subs
implicit none
    type my_type
       integer weight
       real length
    end type my_type
    type (my_type), dimension (:), allocatable :: people
    type (my_type) :: answer
    allocate (people (2))

    people (1) % weight = 1
    people (1) % length = 1.0
    people (2) % weight = 2
    people (2) % length = 2.0

    call my_sum ( people (:) % weight, answer % weight )
    write (*, *)  answer % weight

    call my_sum ( people (:) % length, answer % length )
    write (*, *)  answer % length
end program test_dt


      SUBROUTINE cftrig_g (n, trigs)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER n
      REAL(rprec), DIMENSION(*) :: trigs
!DEC$ IF .NOT.DEFINED (CRAY) .OR. DEFINED(LONESTAR) .OR. DEFINED(MCURIE)
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, two = 2, p5 = .5_dp
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: l, i
      REAL(rprec) :: pi, del, angle
C-----------------------------------------------
      pi = two*ASIN(one)
      del = (pi + pi)/n
      l = n + n
      DO 10 i=1,l,2
        angle=(p5*del)*(i-1)
        trigs(i)=COS(angle)
        trigs(i+1)=SIN(angle)
   10 CONTINUE
!DEC$ ELSE
      CALL cftrig (n, trigs)
!DEC$ ENDIF
      END SUBROUTINE cftrig_g


program main
    use SoilClass
implicit none

! create ground
type(Soil_) :: soil
real(real64),allocatable :: strain(:,:),stress(:,:),trSigma(:),allstress(:,:,:)
integer(int32),parameter :: num_node=10
real(real64) :: E, v
integer(int32) :: i

! import some DEM file
call soil%import("DEM2.vtk")

call soil%msh("DEM3")
print *, size(soil%FEMDomain%PhysicalField)
! show field names
print *, soil%FEMDomain%PhysicalField(1)%name
print *, soil%FEMDomain%PhysicalField(2)%name ! empty
print *, soil%FEMDomain%PhysicalField(3)%name ! empty
!export field with mesh
call soil%vtk("DEM3",vector=soil%FEMDomain%PhysicalField(1)%vector,field="Displacement")

soil%YoungModulus = 10000.0d0
soil%PoissonRatio = 0.30d0
soil%Density      = 1.60d0
soil%VoidRatio    = 0.50d0

call soil%PreFlightCheck()

! only gravity
! [Notice!] automatically Roller boundaries are introduced
!           in the sides and the bottom.
!           If you want to add an additional boundary conditions,
!           please enforce them as the following.
call soil%deform(z_max=2.0d0,disp=[0.0d0,0.0d0,0.0d0])

! all stress tensors
allstress=zeros(soil%femdomain%ne(),3,3 )

! trace of stress tensors
trSigma = zeros(soil%femdomain%ne() )
do i=1,soil%femdomain%ne()
    E = soil%YoungModulus(i)
    v = soil%PoissonRatio(i)
    stress=soil%femdomain%stressMatrix(ElementID=i,E=E,v=v,disp=soil%disp)
    trSigma(i) = trace(stress)
    allstress(i,:,:) = stress(:,:)
enddo

! result
call soil%vtk("DEM_deformed")
call soil%vtk("DEM_deformed_s11",scalar=trSigma,ElementType=VTK_HEXAHEDRON)
call soil%vtk("DEM_deformed_disp",vector=soil%disp,ElementType=VTK_HEXAHEDRON)
call soil%vtk("DEM_deformed_str",tensor=allstress,ElementType=VTK_HEXAHEDRON)

end program main


SUBROUTINE insidf (x1, y1, x2, y2, xc, yc, between)
  !---------------------------------------------------------
  !      checks, if (xc,yc) lies between (x1,y1) and (x2,y2)
  !---------------------------------------------------------
  !   m o d u l e s

  USE kind_param, ONLY: double

  IMPLICIT NONE

  !   d u m m y   a r g u m e n t s

  REAL (double), INTENT (IN) :: x1
  REAL (double), INTENT (IN) :: y1
  REAL (double), INTENT (IN) :: x2
  REAL (double), INTENT (IN) :: y2
  REAL (double), INTENT (IN) :: xc
  REAL (double), INTENT (IN) :: yc
  LOGICAL, INTENT (OUT) :: between
  !-----------------------------------------------
  !   l o c a l   v a r i a b l e s

  REAL (double) :: dot
  !-----------------------------------------------

  dot = (x1-xc) * (x2-xc) + (y1-yc) * (y2-yc)
  IF (dot <= 0.) THEN
     between = .TRUE.
  ELSE
     between = .FALSE.
  END IF
  RETURN
END SUBROUTINE insidf


C     ( Last modified on 30 Jul 2004 at 16:31:38 )
      PROGRAM          CGDMA
C
C  CG_DESCENT test driver for problems derived from SIF files.
C
C  Nick Gould, for CGT Productions.
C  July 2004
C
      INTEGER          NMAX  , IOUT  , N , M , INPUT , MSAVE, IOUTCP
      INTEGER          LP    , MP, I , METHOD, ITER  , NF, NG
      INTEGER          STAT  , ICALL , INSPEC, IPRINT( 2 )
CS    REAL             F, TOL, GNORM , BIGINF, ZERO,
CD    DOUBLE PRECISION F, TOL, GNORM , BIGINF, ZERO,
     *                 STPMIN, STPMAX, TLEV
      LOGICAL          BOUNDS
CS    REAL             DELTA, SIGMA, EPSILON, THETA, GAMMA,
CD    DOUBLE PRECISION DELTA, SIGMA, EPSILON, THETA, GAMMA,
     *                 RHO, ETA, PSI0, PSI1, PSI2, QUADCU, RSTRTF,
     *                 MAXITF, FEPS
      INTEGER          NXPAND, NSECNT
      LOGICAL          QUADST, PRNTLV, PRNTFI, STRULE, ERULE, AWOLFE,
     *                 STEP
CBIG  PARAMETER      ( NMAX = 100000 )
CMED  PARAMETER      ( NMAX =  10000 )
CTOY  PARAMETER      ( NMAX =   1000 )
CCUS  PARAMETER      ( NMAX =  50000 )
      PARAMETER      ( IOUT  = 6 )
      PARAMETER      ( INPUT = 55, INSPEC = 56, IOUTCP = 57 )
CS    PARAMETER      ( BIGINF = 9.0E+19, ZERO = 0.0E0 )
CD    PARAMETER      ( BIGINF = 9.0D+19, ZERO = 0.0D0 )
CS    REAL             X     ( NMAX ), G     ( NMAX ),
CD    DOUBLE PRECISION X     ( NMAX ), G     ( NMAX ),
     *                 D     ( NMAX ), XTEMP  ( NMAX ), GTEMP  ( NMAX )
      CHARACTER * 10   XNAMES( NMAX ), PNAME, CGPARM
      CHARACTER * 15   SPCDAT
      REAL             CPU( 2 ), CALLS( 4 )
      EXTERNAL         EVALF, EVALG
C
C  Open the Spec file for the method.
C
      SPCDAT = 'CG_DESCENT.SPC'
      OPEN ( INSPEC, FILE = SPCDAT, FORM = 'FORMATTED',
     *      STATUS = 'OLD' )
      REWIND INSPEC
C
C  Read input Spec data.
C
C     TOL         : the required norm of the gradient
C     DELTA       : (Wolfe line search parameter)
C     SIGMA       : (Wolfe line search parameter)
C     EPSILON     : (approximate Wolfe threshold factor)
C     THETA       : (update)
C     GAMMA       : (required decay factor in interval)
C     RHO         : (growth factor in bracket)
C     ETA         : (lower bound for cg's beta_k)
C     PSI0        : (factor used in very initial starting guess)
C     PSI1        : (factor previous step multiplied by in QuadStep)
C     PSI2        : (factor previous step is multipled by for startup)
C     QUADCUTOFF  : (lower bound on rel change in f before QuadStep)
C     RESTART_FAC : (restart cg in restart_fac*n iterations)
C     MAXIT_FAC   : (terminate in maxit_fac*n iterations)
C     FEPS        : (stop when value change <= feps*|f|)
C     NEXPAND     : (number of grow/shrink allowed in bracket)
C     NSECANT     : (number of secant steps allowed in line search)
C     QUADSTEP    : (use initial quad interpolation in line search)
C     PRINTLEVEL  : F (no print) T (intermediate results)
C     PRINTFINAL  : F (no print) T (print error messages, final error)
C     STOPRULE    : F (|grad|_infty <= tol) T (... <= tol*(1+|f|))
C     ERULE       : F (eps_k = eps|f|) T (eps_k = eps)
C     AWOLFE      : F (Wolfe) T (+approx Wolfe) 2 (epsilon pert)
C     STEP        : F (no initial line search guess) T (guess in gnorm)
C
      READ ( INSPEC, 1000 ) TOL, DELTA, SIGMA, EPSILON, THETA, GAMMA,
     *                      RHO, ETA, PSI0, PSI1, PSI2, QUADCU, RSTRTF,
     *                      MAXITF, FEPS, NXPAND, NSECNT, QUADST,
     *                      PRNTLV, PRNTFI, STRULE, ERULE, AWOLFE, STEP
C
C  Close input file.
C
      CLOSE ( INSPEC )
C
C  Create the required data input file cg.parm
C
      CGPARM = 'cg.parm'
      OPEN ( IOUTCP, FILE = CGPARM, FORM = 'FORMATTED',
     *       STATUS = 'UNKNOWN' )
      REWIND IOUTCP
      WRITE( IOUTCP, 2100 ) DELTA, SIGMA, EPSILON, THETA, GAMMA,
     *                      RHO, ETA, PSI0, PSI1, PSI1
      WRITE( IOUTCP, 2110 ) QUADCU, RSTRTF, MAXITF, FEPS,
     *                      NXPAND, NSECNT, QUADST, PRNTLV
      WRITE( IOUTCP, 2120 ) PRNTFI, STRULE, ERULE, AWOLFE, STEP
      CLOSE ( IOUTCP )
C
C  Open the relevant file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     *       STATUS = 'OLD' )
C
C  Check to see if there is sufficient room
C
      CALL UDIMEN( INPUT, N )
      IF ( N .GT. NMAX ) THEN
        WRITE( IOUT, 2040 ) 'X     ', 'NMAX  ', N
        STOP
      END IF
C
C  Set up SIF data.
C
      CALL USETUP( INPUT, IOUT, N, X, XTEMP, GTEMP, NMAX )
C
C  Obtain variable names.
C
      CALL UNAMES( N, PNAME, XNAMES )
C
C  Set up algorithmic input data.
C
      BOUNDS  = .FALSE.
      DO 10 I = 1, N
         IF ( XTEMP( I ) .GT. - BIGINF .OR. GTEMP( I ) .LT. BIGINF )
     *      BOUNDS = .TRUE.
   10 CONTINUE
      IF ( BOUNDS ) WRITE( IOUT, 2030 )
      LP     = IOUT
      MP     = IOUT
C
C  Call the optimizer.
C
      CALL CG_DESCENT( TOL, X, N, EVALF, EVALG, STAT, GNORM, F,
     &                 ITER, NF, NG, D, G, XTEMP, GTEMP )
C
C  Terminal exit.
C
      CALL UREPRT( CALLS, CPU )
      WRITE ( IOUT, 2010 ) F, GNORM
      DO 120 I = 1, N
         WRITE( IOUT, 2020 ) XNAMES( I ), X( I ), G( I )
  120 CONTINUE
      WRITE ( IOUT, 2000 ) PNAME, N, INT( CALLS(1) ), INT( CALLS(2) ),
     *                     STAT, F, CPU(1), CPU(2)
      CLOSE( INPUT  )
      STOP
C
C  Non-executable statements.
C
 1000 FORMAT( 15( D10.3, / ), 2( I10, / ), 6( L10, / ), L10 )
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used               :  CG_DESCENT',     /
     *    ,' Problem                 :  ', A10,    /
     *    ,' # variables             =      ', I10 /
     *    ,' # objective functions   =      ', I10 /
     *    ,' # objective gradients   =      ', I10 /
     *     ' Exit code               =      ', I10 /
     *    ,' Final f                 = ', E15.7 /
     *    ,' Set up time             =      ', 0P, F10.2, ' seconds' /
     *     ' Solve time              =      ', 0P, F10.2, ' seconds' //
     *     66('*') / )
 2010 FORMAT( ' Final objective function value  = ', 1P, D12.4,
     *        /, ' Final norm of gradient          = ', 1P, D12.4,
     *        //, '                 X         G ' )
 2020 FORMAT(  1X, A10, 1P, 2D12.4 )
 2030 FORMAT(  /, ' ** Warning from CGDMA. The problem as stated',
     *            ' includes simple bounds. ', /,
     *            '    These bounds will be ignored. ' )
 2040 FORMAT( /, ' ** ERROR from CGDMA. The declared array ', A6,
     *           ' is too small to hold the problem data.', /,
     *           ' Increase ', A6, ' in CGDMA to be at least ', I6,
     *           ' and recompile. Stopping ' )
 2100 FORMAT( 1P, D10.3, 4X,
     * 'delta        Wolfe line search parameter',
     * /, 1P, D10.3, 4X,
     * 'sigma        Wolfe line search parameter',
     * /, 1P, D10.3, 4X,
     * 'epsilon      approximate Wolfe threshold factor',
     * /, 1P, D10.3, 4X,
     * 'theta        update',
     * /, 1P, D10.3, 4X,
     * 'gamma        required decay factor in interval',
     * /, 1P, D10.3, 4X,
     * 'rho          growth factor in bracket',
     * /, 1P, D10.3, 4X,
     * 'eta          lower bound for cg''s beta_k',
     * /, 1P, D10.3, 4X,
     * 'psi0         factor used in very initial starting guess',
     * /, 1P, D10.3, 4X,
     * 'psi1         factor previous step multiplied by in QuadStep',
     * /, 1P, D10.3, 4X,
     * 'psi2         factor previous step is multipled by for startup')
 2110 FORMAT( 1P, D10.3, 4X,
     * 'QuadCutOff   lower bound on rel change in f before QuadStep',
     * /, 1P, D10.3, 4X,
     * 'restart_fac  restart cg in restart_fac*n iterations',
     * /, 1P, D10.3, 4X,
     * 'maxit_fac    terminate in maxit_fac*n iterations',
     * /, 1P, D10.3, 4X,
     * 'feps         stop when value change <= feps*|f|',
     * /, I10, 4X,
     * 'nexpand      number of grow/shrink allowed in bracket',
     * /, I10, 4X,
     * 'nsecant      number of secant steps allowed in line search',
     * /, L10, 4X,
     * 'QuadStep     use initial quad interpolation in line search',
     * /, L10, 4X,
     * 'PrintLevel   F (no print) T (intermediate results)')
 2120 FORMAT(  L10, 4X,
     * 'PrintFinal   F (no print) T (print error messages, ',
     * 'final error)',
     * /, L10, 4X,
     * 'StopRule     F (|grad|_infty <= tol) T (... <= tol*(1+|f|))',
     * /, L10, 4X,
     * 'ERule        F (eps_k = eps|f|) T (eps_k = eps)',
     * /, L10, 4X,
     * 'AWolfe       F (Wolfe) T (+approx Wolfe) 2 (epsilon pert)',
     * /, L10, 4X,
     * 'Step         F (no initial line search guess) T (guess in ',
     * 'gnorm')

      END

      SUBROUTINE EVALF( F, X, N )

C  Evaluate the objective function

      INTEGER N
CS    REAL             F
CD    DOUBLE PRECISION F
CS    REAL             X( N )
CD    DOUBLE PRECISION X( N )
      EXTERNAL UFN

      CALL UFN( N, X, F )

      RETURN
      END

      SUBROUTINE EVALG( G, X, N )

C  Evaluate the gradiuent of the objective function

      INTEGER N
CS    REAL             X( N ), G( N )
CD    DOUBLE PRECISION X( N ), G( N )
      EXTERNAL UGR

      CALL UGR( N, X, G )

      RETURN
      END


c----------------------------------------------------------------------
      subroutine iludp(n,a,ja,ia,alph,droptol,permtol,mbloc,alu,
     *     jlu,ju,iwk,w,jw,iperm,ierr)
c-----------------------------------------------------------------------
      implicit none
      integer n,ja(*),ia(n+1),mbloc,jlu(*),ju(n),jw(2*n),iwk,
     *     iperm(2*n),ierr
      real*8 a(*), alu(*), w(2*n), alph, droptol, permtol
c----------------------------------------------------------------------*
c                     *** ILUDP preconditioner ***                     *
c    incomplete LU factorization with standard droppoing strategy      *
c    and column pivoting                                               *
c----------------------------------------------------------------------*
c author Yousef Saad -- Aug 1995.                                      *
c----------------------------------------------------------------------*
c on entry:
c==========
c n       = integer. The dimension of the matrix A.
c
c a,ja,ia = matrix stored in Compressed Sparse Row format.
c           ON RETURN THE COLUMNS OF A ARE PERMUTED.
c
c alph    = diagonal compensation parameter -- the term:
c
c           alph*(sum of all dropped out elements in a given row)
c
c           is added to the diagonal element of U of the factorization
c           Thus: alph = 0 ---> ~ ILU with threshold,
c                 alph = 1 ---> ~ MILU with threshold.
c
c droptol = tolerance used for dropping elements in L and U.
c           elements are dropped if they are .lt. norm(row) x droptol
c           row = row being eliminated
c
c permtol = tolerance ratio used for determning whether to permute
c           two columns.  Two columns are permuted only when
c           abs(a(i,j))*permtol .gt. abs(a(i,i))
c           [0 --> never permute; good values 0.1 to 0.01]
c
c mbloc   = if desired, permuting can be done only within the diagonal
c           blocks of size mbloc. Useful for PDE problems with several
c           degrees of freedom.. If feature not wanted take mbloc=n.
c
c iwk     = integer. The declared lengths of arrays alu and jlu
c           if iwk is not large enough the code will stop prematurely
c           with ierr = -2 or ierr = -3 (see below).
c
c On return:
c===========
c
c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing
c           the L and U factors together. The diagonal (stored in
c           alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix
c           contains the i-th row of L (excluding the diagonal entry=1)
c           followed by the i-th row of U.
c
c ju      = integer array of length n containing the pointers to
c           the beginning of each row of U in the matrix alu,jlu.
c iperm   = contains the permutation arrays ..
c           iperm(1:n) = old numbers of unknowns
c           iperm(n+1:2*n) = reverse permutation = new unknowns.
c
c ierr    = integer. Error message with the following meaning.
c           ierr  = 0    --> successful return.
c           ierr .gt. 0  --> zero pivot encountered at step number ierr.
c           ierr  = -1   --> Error. input matrix may be wrong.
c                            (The elimination process has generated a
c                            row in L or U whose length is .gt.  n.)
c           ierr  = -2   --> The L/U matrix overflows the arrays alu,jlu
c           ierr  = -3   --> zero row encountered.
c
c work arrays:
c=============
c jw      = integer work array of length 2*n.
c w       = real work array of length 2*n
c
c Notes:
c ------
c IMPORTANT: TO AVOID PERMUTING THE SOLUTION VECTORS ARRAYS FOR EACH
c LU-SOLVE, THE MATRIX A IS PERMUTED ON RETURN. [all column indices are
c changed]. SIMILARLY FOR THE U MATRIX.
c To permute the matrix back to its original state use the loop:
c
c      do k=ia(1), ia(n+1)-1
c         ja(k) = perm(ja(k))
c      enddo
c
c-----------------------------------------------------------------------
c     local variables
c
      integer k,i,j,jrow,ju0,ii,j1,j2,jpos,len,imax,lenu,lenl,jj,icut
      real*8 s,tmp,tnorm,xmax,xmax0,fact,abs,t,dropsum
c-----------------------------------------------------------------------
c     initialize ju0 (points to next element to be added to alu,jlu)
c     and pointer array.
c-----------------------------------------------------------------------
      ju0 = n+2
      jlu(1) = ju0
c
c  integer double pointer array.
c
      do 1 j=1,n
         jw(n+j)  = 0
         iperm(j) = j
         iperm(n+j) = j
 1    continue
c-----------------------------------------------------------------------
c     beginning of main loop.
c-----------------------------------------------------------------------
      do 500 ii = 1, n
         j1 = ia(ii)
         j2 = ia(ii+1) - 1
         dropsum = 0.0d0
         tnorm = 0.0d0
         do 501 k=j1,j2
            tnorm = tnorm+abs(a(k))
 501     continue
         if (tnorm .eq. 0.0) goto 997
         tnorm = tnorm/(j2-j1+1)
c
c     unpack L-part and U-part of row of A in arrays  w  --
c
         lenu = 1
         lenl = 0
         jw(ii) = ii
         w(ii) = 0.0
         jw(n+ii) = ii
c
         do 170  j = j1, j2
            k = iperm(n+ja(j))
            t = a(j)
            if (k .lt. ii) then
               lenl = lenl+1
               jw(lenl) = k
               w(lenl) = t
               jw(n+k) = lenl
            else if (k .eq. ii) then
               w(ii) = t
            else
               lenu = lenu+1
               jpos = ii+lenu-1
               jw(jpos) = k
               w(jpos) = t
               jw(n+k) = jpos
            endif
 170     continue
         jj = 0
         len = 0
c
c     eliminate previous rows
c
 150     jj = jj+1
         if (jj .gt. lenl) goto 160
c-----------------------------------------------------------------------
c     in order to do the elimination in the correct order we must select
c     the smallest column index among jw(k), k=jj+1, ..., lenl.
c-----------------------------------------------------------------------
         jrow = jw(jj)
         k = jj
c
c     determine smallest column index
c
         do 151 j=jj+1,lenl
            if (jw(j) .lt. jrow) then
               jrow = jw(j)
               k = j
            endif
 151     continue
c
         if (k .ne. jj) then
c     exchange in jw
            j = jw(jj)
            jw(jj) = jw(k)
            jw(k) = j
c     exchange in jr
            jw(n+jrow) = jj
            jw(n+j) = k
c     exchange in w
            s = w(jj)
            w(jj) = w(k)
            w(k) = s
         endif
c
c     zero out element in row by resetting jw(n+jrow) to zero.
c
         jw(n+jrow) = 0
c
c     drop term if small
c
         if (abs(w(jj)) .le. droptol*tnorm) then
            dropsum = dropsum + w(jj)
            goto 150
         endif
c
c     get the multiplier for row to be eliminated: jrow
c
         fact = w(jj)*alu(jrow)
c
c     combine current row and row jrow
c
         do 203 k = ju(jrow), jlu(jrow+1)-1
            s = fact*alu(k)
c     new column number
            j = iperm(n+jlu(k))
            jpos = jw(n+j)
c
c     if fill-in element is small then disregard:
c
            if (j .ge. ii) then
c
c     dealing with upper part.
c
               if (jpos .eq. 0) then
c     this is a fill-in element
                  lenu = lenu+1
                  i = ii+lenu-1
                  if (lenu .gt. n) goto 995
                  jw(i) = j
                  jw(n+j) = i
                  w(i) = - s
               else
c     no fill-in element --
                  w(jpos) = w(jpos) - s
               endif
            else
c
c     dealing with lower part.
c
               if (jpos .eq. 0) then
c     this is a fill-in element
                 lenl = lenl+1
                 if (lenl .gt. n) goto 995
                 jw(lenl) = j
                 jw(n+j) = lenl
                 w(lenl) = - s
              else
c     no fill-in element --
                 w(jpos) = w(jpos) - s
              endif
           endif
 203	continue
        len = len+1
        w(len) = fact
        jw(len)  = jrow
	goto 150
 160    continue
c
c     reset double-pointer to zero (U-part)
c
        do 308 k=1, lenu
           jw(n+jw(ii+k-1)) = 0
 308	continue
c
c     update L-matrix
c
        do 204 k=1, len
           if (ju0 .gt. iwk) goto 996
           alu(ju0) =  w(k)
           jlu(ju0) = iperm(jw(k))
           ju0 = ju0+1
 204    continue
c
c     save pointer to beginning of row ii of U
c
        ju(ii) = ju0
c
c     update u-matrix -- first apply dropping strategy
c
         len = 0
         do k=1, lenu-1
            if (abs(w(ii+k)) .gt. tnorm*droptol) then
               len = len+1
               w(ii+len) = w(ii+k)
               jw(ii+len) = jw(ii+k)
            else
               dropsum = dropsum + w(ii+k)
            endif
         enddo
c
        imax = ii
        xmax = abs(w(imax))
        xmax0 = xmax
        icut = ii - 1 + mbloc - mod(ii-1,mbloc)
c
c     determine next pivot --
c
        do k=ii+1,ii+len
           t = abs(w(k))
           if (t .gt. xmax .and. t*permtol .gt. xmax0 .and.
     *          jw(k) .le. icut) then
              imax = k
              xmax = t
           endif
        enddo
c
c     exchange w's
c
        tmp = w(ii)
        w(ii) = w(imax)
        w(imax) = tmp
c
c     update iperm and reverse iperm
c
        j = jw(imax)
        i = iperm(ii)
        iperm(ii) = iperm(j)
        iperm(j) = i
c     reverse iperm
        iperm(n+iperm(ii)) = ii
        iperm(n+iperm(j)) = j
c-----------------------------------------------------------------------
        if (len + ju0-1 .gt. iwk) goto 996
c
c     copy U-part in original coordinates
c
        do 302 k=ii+1,ii+len
           jlu(ju0) = iperm(jw(k))
           alu(ju0) = w(k)
           ju0 = ju0+1
 302	continue
c
c     define diagonal element
c
         w(ii) = w(ii) + alph*dropsum
c
c     store inverse of diagonal element of u
c
        if (w(ii) .eq. 0.0) w(ii) = (1.0D-4 + droptol)*tnorm
c
        alu(ii) = 1.0d0/ w(ii)
c
c     update pointer to beginning of next row of U.
c
	jlu(ii+1) = ju0
c-----------------------------------------------------------------------
c     end main loop
c-----------------------------------------------------------------------
 500  continue
c
c     permute all column indices of LU ...
c
      do k = jlu(1),jlu(n+1)-1
         jlu(k) = iperm(n+jlu(k))
      enddo
c
c     ...and of A
c
      do k=ia(1), ia(n+1)-1
         ja(k) = iperm(n+ja(k))
      enddo
c
      ierr = 0
      return
c
c     incomprehensible error. Matrix must be wrong.
c
 995  ierr = -1
      return
c
c     insufficient storage in arrays alu, jlu to store factors
c
 996  ierr = -2
      return
c
c     zero row encountered
c
 997  ierr = -3
      return
c----------------end-of-iludp-------------------------------------------
c-----------------------------------------------------------------------
      end