c///////////////////////////////////////////////////////////////////////////
c---------------------------------------------------------------------------
      SUBROUTINE SGECO(A,LDA,N,IPVT,RCOND,Z)
c---------------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER LDA,N,IPVT(1)
      REAL A(LDA,1),Z(1)
      REAL RCOND
C
C     SGECO FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION
C     AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C     IF  RCOND  IS NOT NEEDED, SGEFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW SGECO BY SGESL.
C     TO COMPUTE  INVERSE(A)*C , FOLLOW SGECO BY SGESL.
C     TO COMPUTE  DETERMINANT(A) , FOLLOW SGECO BY SGEDI.
C     TO COMPUTE  INVERSE(A) , FOLLOW SGECO BY SGEDI.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE MATRIX TO BE FACTORED.
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     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     LINPACK SGEFA
C     BLAS SAXPY,SDOT,SSCAL,SASUM
C     FORTRAN ABS,AMAX1,SIGN
C
C     INTERNAL VARIABLES
C
      REAL SDOT,EK,T,WK,WKM
      REAL ANORM,S,SASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
C
C
C     COMPUTE 1-NORM OF A
C
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL SGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C     SOLVE TRANS(U)*W = E
C
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K))
         IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30
            S = ABS(A(K,K))/ABS(EK-Z(K))
            CALL SSCAL(N,S,Z,1)
            EK = S*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (A(K,K) .EQ. 0.0E0) GO TO 40
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
         GO TO 50
   40    CONTINUE
            WK = 1.0E0
            WKM = 1.0E0
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + ABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150
            S = ABS(A(K,K))/ABS(Z(K))
            CALL SSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         T = -Z(K)
         CALL SAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
c///////////////////////////////////////////////////////////////////////////
c---------------------------------------------------------------------------
      SUBROUTINE SGESL(A,LDA,N,IPVT,B,JOB)
c---------------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER LDA,N,IPVT(1),JOB
      REAL A(LDA,1),B(1)
C
C     SGESL SOLVES THE REAL SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY SGECO OR SGEFA.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE OUTPUT FROM SGECO OR SGEFA.
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        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SGECO OR SGEFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF SGECO HAS SET RCOND .GT. 0.0
C        OR SGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SDOT
C
C     INTERNAL VARIABLES
C
      REAL SDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL SAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = SDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
      SUBROUTINE SAXPY(n,sa,sx,incx,sy,incy)
      IMPLICIT NONE
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),sy(1),sa
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sy(i) + sa*sx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
   50 continue
      return
      end
      real function sdot(n,sx,incx,sy,incy)
      IMPLICIT NONE
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),sy(1),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      stemp = 0.0e0
      sdot = 0.0e0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = stemp + sx(ix)*sy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      sdot = stemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + sx(i)*sy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
     *   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
   50 continue
   60 sdot = stemp
      return
      end
      SUBROUTINE SSCAL(n,sa,sx,incx)
      IMPLICIT NONE
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to 1.
c     jack dongarra, linpack, 3/11/78.
c
      real sa,sx(1)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        sx(i) = sa*sx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end
      real function sasum(n,sx,incx)
      IMPLICIT NONE
c
c     takes the sum of the absolute values.
c     uses unrolled loops for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),stemp
      integer i,incx,m,mp1,n,nincx
c
      sasum = 0.0e0
      stemp = 0.0e0
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        stemp = stemp + abs(sx(i))
   10 continue
      sasum = stemp
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,6)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + abs(sx(i))
   30 continue
      if( n .lt. 6 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,6
        stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2))
     *  + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5))
   50 continue
   60 sasum = stemp
      return
      end
      SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO)
      IMPLICIT NONE
      INTEGER LDA,N,IPVT(1),INFO
      REAL A(LDA,1)
C
C     SGEFA FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION.
C
C     SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) .
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE MATRIX TO BE FACTORED.
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     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN SGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS SAXPY,SSCAL,ISAMAX
C
C     INTERNAL VARIABLES
C
      REAL T
      INTEGER ISAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ISAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/A(K,K)
            CALL SSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      integer function isamax(n,sx,incx)
      IMPLICIT NONE
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      real sx(1),smax
      integer i,incx,ix,n
c
      isamax = 0
      if( n .lt. 1 ) return
      isamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = abs(sx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(abs(sx(ix)).le.smax) go to 5
         isamax = i
         smax = abs(sx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 smax = abs(sx(1))
      do 30 i = 2,n
         if(abs(sx(i)).le.smax) go to 30
         isamax = i
         smax = abs(sx(i))
   30 continue
      return
      end


use plantfem
use iso_fortran_env
implicit none
integer(int32),parameter ::  N = 10
integer(int32),parameter ::  NRHS = 1
integer(int32),parameter ::  LDA = 10
integer(int32),parameter ::   LDB=10
real(real64) :: A( LDA, N )
real(real64) ::  IPIV(N)
real(real64):: B( LDB, NRHS )
real(real64),allocatable :: A_0(:,:)

integer(int32) :: INFO, i

type(IO_) :: f

call f%open("input_file.txt","r")
do i=1,10
    read(f%fh,*) A(i,:)
enddo
do i=1,10
    read(f%fh,*) B(i,1)
enddo

A_0 = A
CALL DGESV ( N,NRHS,A,LDA,IPIV,B,LDB,INFO )

call print(B)
call print("-")
call print(matmul(A_0,B))

end


*+**********************************************************************
* This file contains code to calculate the aspect ratio of the elements
* in the grid:
*
* WHCALC - Calculates width and height
* ARCALC - Calculates the aspect ratios
* SETARE - Calculates the area of all elements
************************************************************************

      SUBROUTINE WHCALC (DM1M3,DM2M4,IELM,KVERT,DCORVG)
C
C returns:
C   DM1M3 - distance between midpoints M1, M3
C   DM2M4 - distance between midpoints M2, M4
C
      IMPLICIT NONE

      DOUBLE PRECISION DCORVG(2,*)
      INTEGER KVERT(4,*)

      DOUBLE PRECISION DM1M3,DM2M4
      INTEGER IELM

      DOUBLE PRECISION XE1, XE2, XE3, XE4, XM1, XM2, XM3, XM4
      DOUBLE PRECISION YE1, YE2, YE3, YE4, YM1, YM2, YM3, YM4
      INTEGER IECK1, IECK2, IECK3, IECK4

      IECK1=KVERT(1,IELM)
      IECK2=KVERT(2,IELM)
      IECK3=KVERT(3,IELM)
      IECK4=KVERT(4,IELM)

      XE1=DCORVG(1,IECK1)
      YE1=DCORVG(2,IECK1)
      XE2=DCORVG(1,IECK2)
      YE2=DCORVG(2,IECK2)
      XE3=DCORVG(1,IECK3)
      YE3=DCORVG(2,IECK3)
      XE4=DCORVG(1,IECK4)
      YE4=DCORVG(2,IECK4)

      XM1=(XE2+XE1)/2D0
      YM1=(YE2+YE1)/2D0
      XM2=(XE3+XE2)/2D0
      YM2=(YE3+YE2)/2D0
      XM3=(XE4+XE3)/2D0
      YM3=(YE4+YE3)/2D0
      XM4=(XE1+XE4)/2D0
      YM4=(YE1+YE4)/2D0

      DM1M3 = DSQRT((XM3-XM1)**2+(YM3-YM1)**2)
      DM2M4 = DSQRT((XM4-XM2)**2+(YM4-YM2)**2)

      END

      SUBROUTINE ARCALC (RATIO,IELM,KVERT,DCORVG)
****************************************************************
c    by Rainer Schmachtel
C=======================================================================
C    Calculates the aspect ratio (AR) of element IELM,
C    and returns it on RATIO.
C=======================================================================
C-----------------------------------------------------------------------
      IMPLICIT NONE

      DOUBLE PRECISION RATIO, DCORVG(2,*)
      INTEGER KVERT(4,*)

      INTEGER IELM

      DOUBLE PRECISION NENNER, ZAEHLER
      DOUBLE PRECISION XE1, XE2, XE3, XE4, XM1, XM2, XM3, XM4
      DOUBLE PRECISION YE1, YE2, YE3, YE4, YM1, YM2, YM3, YM4
      INTEGER IECK1, IECK2, IECK3, IECK4

      IECK1=KVERT(1,IELM)
      IECK2=KVERT(2,IELM)
      IECK3=KVERT(3,IELM)
      IECK4=KVERT(4,IELM)

      XE1=DCORVG(1,IECK1)
      YE1=DCORVG(2,IECK1)
      XE2=DCORVG(1,IECK2)
      YE2=DCORVG(2,IECK2)
      XE3=DCORVG(1,IECK3)
      YE3=DCORVG(2,IECK3)
      XE4=DCORVG(1,IECK4)
      YE4=DCORVG(2,IECK4)

      XM1=(XE2+XE1)/2D0
      YM1=(YE2+YE1)/2D0
      XM2=(XE3+XE2)/2D0
      YM2=(YE3+YE2)/2D0
      XM3=(XE4+XE3)/2D0
      YM3=(YE4+YE3)/2D0
      XM4=(XE1+XE4)/2D0
      YM4=(YE1+YE4)/2D0

      ZAEHLER=(XM3-XM1)**2+(YM3-YM1)**2
      NENNER =(XM4-XM2)**2+(YM4-YM2)**2

      RATIO=DSQRT(ZAEHLER/MAX(NENNER,1D-10))
C      RATIO=DSQRT(ZAEHLER/NENNER)

      END

************************************************************************
*
* SETARE
*
* Flaecheninhalt aller Elemente bestimmen.
*
*   Purpose: - writes on  AREA(IEL)  the area of the element IEL,
*              IEL=1,...,NEL
*            - writes on  AREA(NEL+1) the sum of all  AREA(IEL)
*            - KVERT,DCORVG are the usual FEAT arrays
*
************************************************************************
C      SUBROUTINE   SETARE  (AREA,NEL,KVERT,DCORVG)
C=======================================================================
C     Declarations
C=======================================================================
C      IMPLICIT NONE

C      INTEGER NNVE
C      PARAMETER (NNVE=4)
C      DOUBLE PRECISION DCORVG(2,*)
C      INTEGER NEL,KVERT(NNVE,*)

C      DOUBLE PRECISION AREA(*)

C      DOUBLE PRECISION SUM,X1,X2,X3,X4,Y1,Y2,Y3,Y4,AAA
C      INTEGER IEL,I1,I2,I3,I4
C=======================================================================
C      SUM=0.D0
C      DO  11  IEL=1,NEL
C
C      I1=KVERT(1,IEL)
C      I2=KVERT(2,IEL)
C      I3=KVERT(3,IEL)
C      I4=KVERT(4,IEL)
C
C      X1=DCORVG(1,I1)
C      X2=DCORVG(1,I2)
C      X3=DCORVG(1,I3)
C      X4=DCORVG(1,I4)
C
C      Y1=DCORVG(2,I1)
C      Y2=DCORVG(2,I2)
C      Y3=DCORVG(2,I3)
C      Y4=DCORVG(2,I4)
C
C Berechnung des Flaecheninhaltes des Rechtecks.
C Dazu wird der Flaecheninhalt der beiden Dreiecke
C (X1,Y1)->(X2,Y2)->(X3,Y3) und (X1,Y1)->(X3,Y3)->(X4,Y4)
C berechnet, indem die Determinante der Matrix aus den aufspannenden
C Vektoren berechnet und halbiert wird.:
C det ( X1-X2 X3-X2 ) + det (X1-X4 X3-X4 )
C       Y1-Y2 Y1-Y3          Y1-Y4 Y3-Y4
C
C      AAA=0.5D0*(  DABS((X1-X2)*(Y3-Y2)-(Y1-Y2)*(X3-X2))
C     *            +DABS((X1-X4)*(Y3-Y4)-(Y1-Y4)*(X3-X4)) )
C      AREA(IEL)=AAA
C      SUM=SUM+AAA
C  11  CONTINUE
C
C      AREA(NEL+1)=SUM
C
C      END


     program demo_random_int
     use M_random, only : random_int, init_random_seed_by_system_clock
     call init_random_seed_by_system_clock()
     write(*,'(*(i0:,1x))')(random_int(1,10),i=1,20)
     write(*,'(*(i0:,1x))')(random_int(-5,5),i=1,20)
     end program demo_random_int


#include "macros.h"

module diffops
    use numbers
    use openmpi
    use io
    use parameters
    use fftw

    contains

!==============================================================================

    complex(dpc) function nabla(ix, iy, iz, d)
        integer(i4), intent(in) :: ix, iy, iz, d

        select case (d)
            case(1)
                nabla = imag_1 * kx(ix)
            case(2)
                nabla = imag_1 * ky(iy)
            case(3)
                nabla = imag_1 * kz(iz)
        end select
    end function nabla

!==============================================================================

    complex(dpc) function laplacian(ix, iy, iz)
        integer(i4), intent(in) :: ix, iy, iz

        laplacian = kx(ix)**2 + ky(iy)**2 + kz(iz)**2
    end function laplacian

!==============================================================================

    complex(dpc) function inverse_laplacian(ix, iy, iz)
        integer(i4), intent(in) :: ix, iy, iz

        if (qx(ix) == 0 .and. qy(iy) == 0 .and. qz(iz) == 0) then
            inverse_laplacian = 0
        else
            inverse_laplacian = 1.0_dp / laplacian(ix,iy,iz)
        end if
    end function inverse_laplacian

!==============================================================================

    subroutine diffops_div(vfieldk, div_vfieldk)

        complex(dpc), intent(in)  :: vfieldk(:, :, :, :)
        complex(dpc), intent(out) :: div_vfieldk(:, :, :)
        integer(i4) :: dim
        _indices

        div_vfieldk = 0

        do dim = 1, 3
            _loop_spec_begin
                div_vfieldk(ix, iy, iz) = div_vfieldk(ix, iy, iz) + &
                    nabla(ix, iy, iz, dim) * vfieldk(ix, iy, iz, dim)
            _loop_spec_end
        end do

    end subroutine diffops_div

!==============================================================================

    subroutine diffops_partx(sfieldk, partx_sfieldk)

        complex(dpc), intent(in)  :: sfieldk(:, :, :)
        complex(dpc), intent(out) :: partx_sfieldk(:, :, :)
        _indices

        _loop_spec_begin
            partx_sfieldk(ix, iy, iz) = imag_1 * kx(ix) * sfieldk(ix, iy, iz)
        _loop_spec_end

    end subroutine diffops_partx

!==============================================================================

    subroutine diffops_party(sfieldk, party_sfieldk)

        complex(dpc), intent(in)  :: sfieldk(:, :, :)
        complex(dpc), intent(out) :: party_sfieldk(:, :, :)
        _indices

        _loop_spec_begin
            party_sfieldk(ix, iy, iz) = imag_1 * ky(iy) * sfieldk(ix, iy, iz)
        _loop_spec_end

    end subroutine diffops_party

!==============================================================================

    subroutine diffops_partz(sfieldk, partz_sfieldk)

        complex(dpc), intent(in)  :: sfieldk(:, :, :)
        complex(dpc), intent(out) :: partz_sfieldk(:, :, :)
        _indices

        _loop_spec_begin
            partz_sfieldk(ix, iy, iz) = imag_1 * kz(iz) * sfieldk(ix, iy, iz)
        _loop_spec_end

    end subroutine diffops_partz

!==============================================================================

end module diffops


! Author of the program Vladimir Fuka
! Modified by
! Donato Cecere
! 1 July 2007

module CUeuler
    implicit none

    integer,parameter:: KND=KIND(1.0D0)

    integer RKtype   !(1 - 1. order ... 3 - 3. order, 4. fully discrete)
    integer FLUXtype !(1 - KURGTADMOR, 2 - CENTUPW, 3 - LAXFRIED, 4 - LAXWENDROFF,5 - MUSTA)
    integer MUSTAstages!(Number of stages for MUSTA flux, for 1 it reduces to FORCE flux)
    integer RECtype  !(1 - piecewise constant,  2 - piecewise linear)
    integer limitertype !(1 - minmod, 2 - modified minmod (MC), 3 - modified superbee)
    real(KND) limparam !(parameter for limiter - only if needed)
    integer extype   !(1 - shock tube test, 2 - smooth test case with periodic BC)
    integer outputtype !(1 - single frame textfiles for gnuplot, 2- one Tecplot file) Tecplot output by Donato Cecere, beta
    integer nx,nt

    real(KND) time,dx,xl,xr,dt,tend,CFL,rhoLEFT,rhouLEFT,eLEFT,rhoRIGHT,rhouRIGHT,eRIGHT

    real(KND),parameter:: gamma=1.4_KND, pi=3.1415926535_KND

    interface MINMOD
         module procedure MINMOD2, MINMOD3
    end interface

    contains

    subroutine TMARCH(rho,rhou,e,x)
     integer i
     real(KND),dimension(-2:):: rho,rhou,e,x
	 !real(KND),dimension(-2:nx+3):: rho,rhou,e
	 real(KND),dimension(LBOUND(rho,1):UBOUND(rho,1)):: rho2,rhou2,e2,drho,drhou,de

     if (RKtype==1) then
      call DRK(drho,drhou,de,rho,rhou,e,x)
      rho=rho + dt*drho
      rhou=rhou + dt*drhou
      e=e + dt*de

     elseif (RKtype==2) then
      call DRK(drho,drhou,de,rho,rhou,e,x)
      rho2=rho + dt*drho
      rhou2=rhou + dt*drhou
      e2=e + dt*de

      call DRK(drho,drhou,de,rho2,rhou2,e2,x)
      rho=(1._KND/2._KND)*rho + (1._KND/2._KND)*rho2 + (1._KND/2._KND)*dt*drho
      rhou=(1._KND/2._KND)*rhou + (1._KND/2._KND)*rhou2 + (1._KND/2._KND)*dt*drhou
      e=(1._KND/2._KND)*e + (1._KND/2._KND)*e2 + (1._KND/2._KND)*dt*de

     elseif (RKtype==3) then

      call DRK(drho,drhou,de,rho,rhou,e,x) !1
      rho2=rho + dt*drho
      rhou2=rhou + dt*drhou
      e2=e + dt*de

      call DRK(drho,drhou,de,rho2,rhou2,e2,x) !2
      rho2=(3._KND/4._KND)*rho + (1._KND/4._KND)*rho2 + (1._KND/4._KND)*dt*drho
      rhou2=(3._KND/4._KND)*rhou + (1._KND/4._KND)*rhou2 + (1._KND/4._KND)*dt*drhou
      e2=(3._KND/4._KND)*e + (1._KND/4._KND)*e2 + (1._KND/4._KND)*dt*de

      call DRK(drho,drhou,de,rho2,rhou2,e2,x) !3
      rho=(1._KND/3._KND)*rho + (2._KND/3._KND)*rho2 + (2._KND/3._KND)*dt*drho
      rhou=(1._KND/3._KND)*rhou + (2._KND/3._KND)*rhou2 + (2._KND/3._KND)*dt*drhou
      e=(1._KND/3._KND)*e + (2._KND/3._KND)*e2 + (2._KND/3._KND)*dt*de

     elseif (RKtype==4) then
      call DFD(rho,rhou,e)
     endif
    endsubroutine TMARCH

    subroutine DRK(drho,drhou,de,rho,rhou,e,x)
     real(KND),dimension(-2:):: rho,rhou,e,drho,drhou,de,x
     real(KND),allocatable,dimension(:):: rhoL,rhouL,eL,rhoR,rhouR,eR
     drho=0
     drhou=0
     de=0

     allocate(rhoL(-2:nx+2))
     allocate(rhouL(-2:nx+2))
     allocate(eL(-2:nx+2))

     allocate(rhoR(-2:nx+2))
     allocate(rhouR(-2:nx+2))
     allocate(eR(-2:nx+2))

     call BOUND(rho,rhou,e) !boundary condition
     if (RECtype==1) then
         call PCONST(rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e)
     elseif (RECtype==2) then
         call MUSCL(rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e,x)
     endif

     if (FLUXtype==1) then
         call FLUXESKT(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR,x)
     elseif (FLUXtype==2) then
         call FLUXESCU(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
     elseif (FLUXtype==3) then
         call FLUXESLF(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
     elseif (FLUXtype==4) then
         call FLUXESLW(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
     elseif (FLUXtype==5) then
         call FLUXESMUSTA(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
     elseif (FLUXtype==6) then
         call FLUXESCULD(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
     endif

     deallocate(rhoL,rhoR,rhouL,rhouR,eL,eR)
    endsubroutine DRK

    subroutine DFD(rho,rhou,e)
     real(KND),dimension(-2:):: rho,rhou,e

     if (FLUXtype==3) then
         call FDLF(rho,rhou,e)
     elseif (FLUXtype==4) then
         call FDLW(rho,rhou,e)
     endif
    endsubroutine DFD

! This procedure calculates  extrapolated values  of the dependent variables using
! a central difference scheme: k = 1, see Tannehill-Anderson-Pletcher, pp. 204-205.
! The values for  the  extrapolated variables  on both sides  of the interface are
! calculated on  the left of i point.

    subroutine MUSCL(rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e,x)
     real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e,x
     real(KND) sL,sC,sR
     integer i

        do i=0,nx+1
!         sL=(rho(i)-rho(i-1))
         sL=(rho(i)-rho(i-1))/(x(i)-x(i-1))
!         sR=(rho(i+1)-rho(i))
         sR=(rho(i+1)-rho(i))/(x(i+1)-x(i))
         sL=sL
         sR=sR
         sC=LIMITER(sL,sR)
         rhoR(i)=rho(i)-sC*(0.5_KND)*(x(i)-x(i-1))
         rhoL(i+1)=rho(i)+sC*(0.5_KND)*(x(i+1)-x(i))
        enddo
        do i=0,nx+1
!         sL=(rhou(i)-rhou(i-1))
         sL=(rhou(i)-rhou(i-1))/(x(i)-x(i-1))
!         sR=(rhou(i+1)-rhou(i))
         sR=(rhou(i+1)-rhou(i))/(x(i+1)-x(i))
         sL=sL
         sR=sR
         sC=LIMITER(sL,sR)
         rhouR(i)=rhou(i)-sC*(0.5_KND)*(x(i)-x(i-1))
         rhouL(i+1)=rhou(i)+sC*(0.5_KND)*(x(i+1)-x(i))
        enddo
        do i=0,nx+1
!         sL=(e(i)-e(i-1))
         sL=(e(i)-e(i-1))/(x(i)-x(i-1))
!         sR=(e(i+1)-e(i))
         sR=(e(i+1)-e(i))/(x(i+1)-x(i))
         sL=sL
         sR=sR
         sC=LIMITER(sL,sR)
         eR(i)=e(i)-sC*(0.5_KND)*(x(i)-x(i-1))
         eL(i+1)=e(i)+sC*(0.5_KND)*(x(i+1)-x(i))
        enddo
   endsubroutine MUSCL
! Linear Piecewise extrapolation
   subroutine PCONST(rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e)
     real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR,rho,rhou,e

     integer i

        do i=0,nx+1
         rhoR(i)=rho(i)
         rhoL(i+1)=rho(i)
        enddo
        do i=0,nx+1
         rhouR(i)=rhou(i)
         rhouL(i+1)=rhou(i)
        enddo
        do i=0,nx+1
         eR(i)=e(i)
         eL(i+1)=e(i)
        enddo
   endsubroutine PCONST

   subroutine FLUXESLF(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,pL,pR
    real(KND) p,A
    integer i

    do i=1,nx+1
        pL(i)=(gamma-1._KND)*(eL(i)-(1._KND/2._KND)*(rhouL(i)*rhouL(i))/rhoL(i))
        pR(i)=(gamma-1._KND)*(eR(i)-(1._KND/2._KND)*(rhouR(i)*rhouR(i))/rhoR(i))
        if ((pL(i)<0).or.(pR(i)<0)) write(*,*) "ERROR! pressure < 0",pL(i),pR(i)
    enddo

   A=dx/(dt)
    !
    !flux of rho
    !
   drho(1)=-(frho(rhoL(1),rhouL(1),eL(1),pL(1))+frho(rhoR(1),rhouR(1),eR(1),pR(1))&
             -A*(rhoR(1)-rhoL(1)))/dx

     do i=2,nx
      p=frho(rhoL(i),rhouL(i),eL(i),pL(i))+frho(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A*(rhoR(i)-rhoL(i))
      drho(i-1)=drho(i-1)+p/dx
      drho(i)=drho(i)-p/dx
     enddo
    drho(nx)=drho(nx)+(frho(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(1))&
                     +frho(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(1))&
         -A*(rhoR(nx+1)-rhoL(nx+1)))/dx

    drho=-drho/2._KND

    !
    !flux of rho*u
    !
    drhou(1)=-(frhou(rhoL(1),rhouL(1),eL(1),pL(1))+frhou(rhoR(1),rhouR(1),eR(1),pR(1))&
         -A*(rhouR(1)-rhouL(1)))/dx
    do i=2,nx
      p=frhou(rhoL(i),rhouL(i),eL(i),pL(i))+frhou(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A*(rhouR(i)-rhouL(i))
      drhou(i-1)=drhou(i-1)+p/dx
      drhou(i)=drhou(i)-p/dx
    enddo
   drhou(nx)=drhou(nx)+(frhou(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       +frhou(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
         -A*(rhouR(nx+1)-rhouL(nx+1)))/dx

    drhou=-drhou/2._KND

    !
    !flux ef energy
    !
    de(1)=-(fe(rhoL(1),rhouL(1),eL(1),pL(1))+fe(rhoR(1),rhouR(1),eR(1),pR(1))&
         -A*(eR(1)-eL(1)))/dx
    do i=2,nx
      p=fe(rhoL(i),rhouL(i),eL(i),pL(i))+fe(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A*(eR(i)-eL(i))
      de(i-1)=de(i-1)+p/dx
      de(i)=de(i)-p/dx
    enddo
    de(nx)=de(nx)+(fe(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                  +fe(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
         -A*(eR(nx+1)-eL(nx+1)))/dx

    de=-de/2._KND
   endsubroutine FLUXESLF

   subroutine FLUXESLW(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,flrho,flrhou,fle
    real(KND) A,pL,pR,pM
    real(KND),DIMENSION(1:3):: qL,qR,qM,fl,fr
    integer i
    real(KND),PARAMETER:: eps=0.0001

    A=dx/dt
    do i=1,nx+1
      qL=(/ rhoL(i),rhouL(i),eL(i) /)
      qR=(/ rhoR(i),rhouR(i),eR(i) /)
      pL=(gamma-1._KND)*(eL(i)-0.5_KND*(rhouL(i)*rhouL(i))/rhoL(i))
      pR=(gamma-1._KND)*(eR(i)-0.5_KND*(rhouR(i)*rhouR(i))/rhoR(i))
      if (pL<0)  pL=0
      if (pR<0)  pR=0

      fl(1)=frho(qL(1),qL(2),qL(3),pL)
      fl(2)=frhou(qL(1),qL(2),qL(3),pL)
      fl(3)=fe(qL(1),qL(2),qL(3),pL)
      fr(1)=frho(qR(1),qR(2),qR(3),pR)
      fr(2)=frhou(qR(1),qR(2),qR(3),pR)
      fr(3)=fe(qR(1),qR(2),qR(3),pR)

      qM=0.5_KND*(qL+qR)-(0.5_KND/A)*(fr-fl)
      if (qM(1)<eps)  qM(1)=eps
      if (qM(3)<eps)  qM(3)=eps
      pM=(gamma-1._KND)*(qM(3)-0.5_KND*(qM(2)*qM(2))/qM(1))
      if (pM<0)  pM=0

      flrho(i)=frho(qM(1),qM(2),qM(3),pM)
      flrhou(i)=frhou(qM(1),qM(2),qM(3),pM)
      fle(i)=fe(qM(1),qM(2),qM(3),pM)
    enddo

    drho(1)=flrho(1)/dx
    drhou(1)=flrhou(1)/dx
    de(1)=fle(1)/dx
    do i=2,nx
     drho(i-1)=drho(i-1)-flrho(i)/dx
     drhou(i-1)=drhou(i-1)-flrhou(i)/dx
     de(i-1)=de(i-1)-fle(i)/dx
     drho(i)=flrho(i)/dx
     drhou(i)=flrhou(i)/dx
     de(i)=fle(i)/dx
    enddo
    drho(nx)=drho(nx)-flrho(nx+1)/dx
    drhou(nx)=drhou(nx)-flrhou(nx+1)/dx
    de(nx)=de(nx)-fle(nx+1)/dx

   endsubroutine FLUXESLW

   subroutine FLUXESKT(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR,x) !!!!!!!!!!!!!!!!!!!!KURGANOV TADMOR SCHEME !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR,x
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,A,pL,pR
    real(KND) p,cL,cR,dxnotu
    integer i

    do i=1,nx+1
        pL(i)=(gamma-1._KND)*(eL(i)-(1._KND/2._KND)*(rhouL(i)*rhouL(i))/rhoL(i))
        pR(i)=(gamma-1._KND)*(eR(i)-(1._KND/2._KND)*(rhouR(i)*rhouR(i))/rhoR(i))
        if ((pL(i)<0).or.(pR(i)<0)) write(*,*) "ERROR! pressure < 0",pL(i),pR(i), &
         eL(i),(1._KND/2._KND)*(rhouL(i)*rhouL(i))/rhoL(i),eR(i),(1._KND/2._KND)*(rhouR(i)*rhouR(i))/rhoR(i)

        cL=SQRT(gamma*pL(i)/rhoL(i))
        cR=SQRT(gamma*pR(i)/rhoR(i))
        A(i)=MAX(ABS(rhouL(1)/rhoL(1)-cL),ABS(rhouR(1)/rhoR(1)-cR),&
              ABS(rhouL(1)/rhoL(1)+cL),ABS(rhouR(1)/rhoR(1)+cR))
    enddo

	drho  = 0.d0 !PER CHIAREZZA
    drhou = 0.d0
	de    = 0.d0

	!
    !flux of rho
    !
!     drho(1)=-(frho(rhoL(1),rhouL(1),eL(1),pL(1))+frho(rhoR(1),rhouR(1),eR(1),pR(1))&
!             -A(1)*(rhoR(1)-rhoL(1)))/dx
     drho(1)=-(frho(rhoL(1),rhouL(1),eL(1),pL(1))+frho(rhoR(1),rhouR(1),eR(1),pR(1))&
             -A(1)*(rhoR(1)-rhoL(1)))

     do i=2,nx
      p=frho(rhoL(i),rhouL(i),eL(i),pL(i))+frho(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A(i)*(rhoR(i)-rhoL(i))
!      drho(i-1)=drho(i-1)+p/dx
      drho(i-1)=drho(i-1)+p
!      drho(i)=drho(i)-p/dx
      drho(i)=drho(i)-p
     enddo
!    drho(nx)=drho(nx)+(frho(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(1))&
!                     +frho(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(1))&
!         -A(nx+1)*(rhoR(nx+1)-rhoL(nx+1)))/dx
!    drho=-drho/2._KND
    drho(nx)=drho(nx)+(frho(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(1))&
                     +frho(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(1))&
         -A(nx+1)*(rhoR(nx+1)-rhoL(nx+1)))

     do i=1,nx
	  dxnotu = (x(i+1)-x(i-1))
      drho(i) = -drho(i)/dxnotu
     enddo

    !
    !flux of rho*u
    !
!    drhou(1)=-(frhou(rhoL(1),rhouL(1),eL(1),pL(1))+frhou(rhoR(1),rhouR(1),eR(1),pR(1))&
!         -A(1)*(rhouR(1)-rhouL(1)))/dx
    drhou(1)=-(frhou(rhoL(1),rhouL(1),eL(1),pL(1))+frhou(rhoR(1),rhouR(1),eR(1),pR(1))&
         -A(1)*(rhouR(1)-rhouL(1)))
    do i=2,nx
      p=frhou(rhoL(i),rhouL(i),eL(i),pL(i))+frhou(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A(i)*(rhouR(i)-rhouL(i))
!      drhou(i-1)=drhou(i-1)+p/dx
      drhou(i-1)=drhou(i-1)+p
!      drhou(i)=drhou(i)-p/dx
      drhou(i)=drhou(i)-p
    enddo
!    drhou(nx)=drhou(nx)+(frhou(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
!                       +frhou(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
!         -A(nx+1)*(rhouR(nx+1)-rhouL(nx+1)))/dx
!    drhou=-drhou/2._KND
    drhou(nx)=drhou(nx)+(frhou(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       +frhou(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
         -A(nx+1)*(rhouR(nx+1)-rhouL(nx+1)))

	 do i=1,nx
	  dxnotu = (x(i+1)-x(i-1))
      drhou(i) = -drhou(i)/dxnotu
     enddo

    !
    !flux ef energy
    !
!    de(1)=-(fe(rhoL(1),rhouL(1),eL(1),pL(1))+fe(rhoR(1),rhouR(1),eR(1),pR(1))&
!         -A(1)*(eR(1)-eL(1)))/dx
    de(1)=-(fe(rhoL(1),rhouL(1),eL(1),pL(1))+fe(rhoR(1),rhouR(1),eR(1),pR(1))&
         -A(1)*(eR(1)-eL(1)))
    do i=2,nx
      p=fe(rhoL(i),rhouL(i),eL(i),pL(i))+fe(rhoR(i),rhouR(i),eR(i),pR(i))&
         -A(i)*(eR(i)-eL(i))
!      de(i-1)=de(i-1)+p/dx
!      de(i)=de(i)-p/dx
      de(i-1)=de(i-1)+p
      de(i)=de(i)-p
    enddo
!    de(nx)=de(nx)+(fe(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
!                  +fe(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
!         -A(nx+1)*(eR(nx+1)-eL(nx+1)))/dx
!    de=-de/2._KND
    de(nx)=de(nx)+(fe(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                  +fe(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1))&
         -A(nx+1)*(eR(nx+1)-eL(nx+1)))
	 do i=1,nx
	  dxnotu = (x(i+1)-x(i-1))
      de(i) = -de(i)/dxnotu
     enddo
   endsubroutine FLUXESKT

   subroutine FLUXESCU(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR)
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,aL,aR,pL,pR
    real(KND) cL,cR,p
    integer i

    do i=1,nx+1
        pL(i)=(gamma-1._KND)*(eL(i)-(1._KND/2._KND)*(rhouL(i)*rhouL(i))/rhoL(i))
        pR(i)=(gamma-1._KND)*(eR(i)-(1._KND/2._KND)*(rhouR(i)*rhouR(i))/rhoR(i))
        if ((pL(i)<0).or.(pR(i)<0)) then
          write(*,*) "ERROR! pressure < 0",pL(i),pR(i)
        endif
        cL=SQRT(gamma*pL(i)/rhoL(i))
        cR=SQRT(gamma*pR(i)/rhoR(i))
        aL(i)=MIN(rhouL(i)/rhoL(i)-cL,rhouR(i)/rhoR(i)-cR,0._KND)
        aR(i)=MAX(rhouL(i)/rhoL(i)+cL,rhouR(i)/rhoR(i)+cR,0._KND)
    enddo

    !
    !flux of rho
    !

   drho(1)=-((aR(1)*frho(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*frho(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1)/(aR(1)-aL(1)))*(rhoR(1)-rhoL(1)))/dx

     do i=2,nx
      p=(aR(i)*frho(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*frho(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i)/(aR(i)-aL(i)))*(rhoR(i)-rhoL(i))
      drho(i-1)=drho(i-1)+p/dx
      drho(i)=drho(i)-p/dx
     enddo
    drho(nx)=drho(nx)+((aR(nx+1)*frho(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       -aL(nx+1)*frho(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
                       +(aL(nx+1)*aR(nx+1)/(aR(nx+1)-aL(nx+1)))*(rhoR(nx+1)-rhoL(nx+1)))/dx

    drho=-drho

    !
    !flux of rho*u
    !
   drhou(1)=-((aR(1)*frhou(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*frhou(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1)/(aR(1)-aL(1)))*(rhouR(1)-rhouL(1)))/dx

     do i=2,nx
      p=(aR(i)*frhou(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*frhou(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i)/(aR(i)-aL(i)))*(rhouR(i)-rhouL(i))
      drhou(i-1)=drhou(i-1)+p/dx
      drhou(i)=drhou(i)-p/dx
     enddo
    drhou(nx)=drhou(nx)+((aR(nx+1)*frhou(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       -aL(nx+1)*frhou(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
                       +(aL(nx+1)*aR(nx+1)/(aR(nx+1)-aL(nx+1)))*(rhouR(nx+1)-rhouL(nx+1)))/dx

    drhou=-drhou

    !
    !flux ef energy
    !
   de(1)=-((aR(1)*fe(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*fe(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1)/(aR(1)-aL(1)))*(eR(1)-eL(1)))/dx

     do i=2,nx
      p=(aR(i)*fe(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*fe(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i)/(aR(i)-aL(i)))*(eR(i)-eL(i))
      de(i-1)=de(i-1)+p/dx
      de(i)=de(i)-p/dx
     enddo
    de(nx)=de(nx)+((aR(nx+1)*fe(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       -aL(nx+1)*fe(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
                       +(aL(nx+1)*aR(nx+1)/(aR(nx+1)-aL(nx+1)))*(eR(nx+1)-eL(nx+1)))/dx

    de=-de

   endsubroutine FLUXESCU

   subroutine FLUXESCULD(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR) !by Donato Cecere
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,aL,aR,pL,pR
    real(KND) cL,cR,p,sL,sR,wint,adt
    integer i

    do i=1,nx+1
        pL(i)=(gamma-1._KND)*(eL(i)-(1._KND/2._KND)*(rhouL(i)*rhouL(i))/rhoL(i))
        pR(i)=(gamma-1._KND)*(eR(i)-(1._KND/2._KND)*(rhouR(i)*rhouR(i))/rhoR(i))
        if ((pL(i)<0).or.(pR(i)<0)) then
          write(*,*) "ERROR! pressure < 0",pL(i),pR(i)
        endif
        cL=SQRT(gamma*pL(i)/rhoL(i))
        cR=SQRT(gamma*pR(i)/rhoR(i))
        aL(i)=MIN(rhouL(i)/rhoL(i)-cL,rhouR(i)/rhoR(i)-cR,0._KND)
        aR(i)=MAX(rhouL(i)/rhoL(i)+cL,rhouR(i)/rhoR(i)+cR,0._KND)
    enddo

    !
    !flux of rho
    !
     ! 1
     wint   = (aR(1)*rhoR(1) -&
      aL(1)*rhoL(1)-(frho(rhoR(1),rhouR(1),eR(1),pR(1)) -&
       frho(rhoL(1),rhouL(1),eL(1),pL(1))))/(aR(1)-aL(1))
     sR     = (rhoR(1) - wint)/(aR(1)-aL(1))
	 sL     = (wint - rhoL(1))/(aR(1)-aL(1))
	 adt    = LIMITER(sL,sR)
     drho(1)=-((aR(1)*frho(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*frho(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1))*((rhoR(1)-rhoL(1))/(aR(1)-aL(1)) - adt))/dx

     do i=2,nx
      wint  = (aR(i)*rhoR(i) -&
       aL(i)*rhoL(i)-(frho(rhoR(i),rhouR(i),eR(i),pR(i)) -&
        frho(rhoL(i),rhouL(i),eL(i),pL(i))))/(aR(i)-aL(i))
      sR    = (rhoR(i) - wint)/(aR(i)-aL(i))
          sL    = (wint - rhoL(i))/(aR(i)-aL(i))
          adt   = LIMITER(sL,sR)
         p  =(aR(i)*frho(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*frho(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i)*(   (rhoR(i)-rhoL(i))/(aR(i)-aL(i)) - adt ))
      drho(i-1)=drho(i-1)+p/dx
      drho(i)=drho(i)-p/dx
     enddo

	 ! nx
     wint = (aR(nx)*rhoR(nx) -&
      aL(nx)*rhoL(nx)-(frho(rhoR(nx),rhouR(nx),eR(nx),pR(nx)) -&
       frho(rhoL(nx),rhouL(nx),eL(nx),pL(nx))))/(aR(nx)-aL(nx))
     sR   = (rhoR(nx) - wint)/(aR(nx)-aL(nx))
     sL   = (wint - rhoL(nx))/(aR(nx)-aL(nx))
     adt  = LIMITER(sL,sR)
     drho(nx)=drho(nx)+((aR(nx+1)*frho(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
      -aL(nx+1)*frho(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
      +(aL(nx+1)*aR(nx+1))*((rhoR(nx+1)-rhoL(nx+1))/(aR(nx+1)-aL(nx+1)) - adt))/dx

     drho=-drho

     !
     !flux of rho*u
     !
	 ! 1
     wint = (aR(1)*rhouR(1) -&
      aL(1)*rhouL(1)-(frhou(rhoR(1),rhouR(1),eR(1),pR(1)) -&
       frhou(rhoL(1),rhouL(1),eL(1),pL(1))))/(aR(1)-aL(1))
     sR   = (rhouR(1) - wint)/(aR(1)-aL(1))
     sL   = (wint - rhouL(1))/(aR(1)-aL(1))
     adt  = LIMITER(sL,sR)
     drhou(1)=-((aR(1)*frhou(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*frhou(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1))*((rhouR(1)-rhouL(1))/(aR(1)-aL(1)) - adt))/dx

     do i=2,nx
     wint = (aR(i)*rhouR(i) -&
      aL(i)*rhouL(i)-(frhou(rhoR(i),rhouR(i),eR(i),pR(i)) -&
       frhou(rhoL(i),rhouL(i),eL(i),pL(i))))/(aR(i)-aL(i))
     sR   = (rhouR(i) - wint)/(aR(i)-aL(i))
     sL   = (wint - rhouL(i))/(aR(i)-aL(i))
     adt  = LIMITER(sL,sR)
     p=(aR(i)*frhou(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*frhou(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i))*((rhouR(i)-rhouL(i))/(aR(i)-aL(i)) - adt)
      drhou(i-1)=drhou(i-1)+p/dx
      drhou(i)=drhou(i)-p/dx
     enddo
	 ! nx
     wint = (aR(nx)*rhouR(nx) -&
      aL(nx)*rhouL(nx)-(frhou(rhoR(nx),rhouR(nx),eR(nx),pR(nx)) -&
       frhou(rhoL(nx),rhouL(nx),eL(nx),pL(nx))))/(aR(nx)-aL(nx))
     sR   = (rhouR(nx) - wint)/(aR(nx)-aL(nx))
     sL   = (wint - rhouL(nx))/(aR(i)-aL(nx))
     adt  = LIMITER(sL,sR)
     drhou(nx)=drhou(nx)+((aR(nx+1)*frhou(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       -aL(nx+1)*frhou(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
                       +(aL(nx+1)*aR(nx+1))*((rhouR(nx+1)-rhouL(nx+1))/(aR(nx+1)-aL(nx+1))))/dx

     drhou=-drhou

     !
     !flux ef energy
     !
	 ! 1
     wint = (aR(1)*rhouR(1) - aL(1)*rhouL(1)-(fe(rhoR(1),rhouR(1),eR(1),pR(1)) - fe(rhoL(1),rhouL(1),eL(1),pL(1))))/(aR(1)-aL(1))
     sR   = (rhouR(1) - wint)/(aR(1)-aL(1))
     sL   = (wint - rhouL(1))/(aR(1)-aL(1))
     adt  = LIMITER(sL,sR)
     de(1)=-((aR(1)*fe(rhoL(1),rhouL(1),eL(1),pL(1))&
             -aL(1)*fe(rhoR(1),rhouR(1),eR(1),pR(1)))/(aR(1)-aL(1))&
             +(aL(1)*aR(1))*((eR(1)-eL(1))/(aR(1)-aL(1)) - adt))/dx

     do i=2,nx
     wint = (aR(i)*rhouR(i) - aL(i)*rhouL(i)-(fe(rhoR(i),rhouR(i),eR(i),pR(i)) - fe(rhoL(i),rhouL(i),eL(i),pL(i))))/(aR(i)-aL(i))
     sR   = (rhouR(i) - wint)/(aR(i)-aL(i))
     sL   = (wint - rhouL(i))/(aR(i)-aL(i))
     adt  = LIMITER(sL,sR)
      p=(aR(i)*fe(rhoL(i),rhouL(i),eL(i),pL(i))&
            -aL(i)*fe(rhoR(i),rhouR(i),eR(i),pR(i)))/(aR(i)-aL(i))&
            +(aL(i)*aR(i))*((eR(i)-eL(i))/(aR(i)-aL(i)) - adt)
      de(i-1)=de(i-1)+p/dx
      de(i)=de(i)-p/dx
     enddo
	 ! nx
     wint = (aR(nx)*rhouR(nx) -&
      aL(nx)*rhouL(nx)-(fe(rhoR(nx),rhouR(nx),eR(nx),pR(nx)) -&
       fe(rhoL(nx),rhouL(nx),eL(nx),pL(nx))))/(aR(nx)-aL(nx))
     sR   = (rhouR(nx) - wint)/(aR(nx)-aL(nx))
     sL   = (wint - rhouL(nx))/(aR(nx)-aL(nx))
     adt  = LIMITER(sL,sR)
     de(nx)=de(nx)+((aR(nx+1)*fe(rhoL(nx+1),rhouL(nx+1),eL(nx+1),pL(nx+1))&
                       -aL(nx+1)*fe(rhoR(nx+1),rhouR(nx+1),eR(nx+1),pR(nx+1)))/(aR(nx+1)-aL(nx+1))&
                       +(aL(nx+1)*aR(nx+1))*(eR(nx+1)-eL(nx+1))/(aR(nx+1)-aL(nx+1)) - adt)/dx

    de=-de

   endsubroutine FLUXESCULD

    subroutine FLUXESMUSTA(drho,drhou,de,rhoL,rhouL,eL,rhoR,rhouR,eR) !MUSTA
    real(KND),dimension(-2:)::rhoL,rhouL,eL,rhoR,rhouR,eR
    real(KND),dimension(LBOUND(rhoL,1):UBOUND(rhoL,1))::drho,drhou,de,&
                                                      flrho,flrhou,fle
    real(KND) p,A,pL,pR,pM
    real(KND),dimension(1:3):: qL,qR,qM,fL,fR,fM
    integer i,l

    A=dx/dt
    do i=1,nx+1
stg: do l=1,MUSTAstages
      if (l==1) then
       qL=(/ rhoL(i),rhouL(i),eL(i) /)
       qR=(/ rhoR(i),rhouR(i),eR(i) /)
       pL=(gamma-1._KND)*(eL(i)-0.5_KND*(rhouL(i)*rhouL(i))/rhoL(i))
       pR=(gamma-1._KND)*(eR(i)-0.5_KND*(rhouR(i)*rhouR(i))/rhoR(i))
      endif
      !predictor step
      fl(1)=frho(qL(1),qL(2),qL(3),pL)
      fl(2)=frhou(qL(1),qL(2),qL(3),pL)
      fl(3)=fe(qL(1),qL(2),qL(3),pL)
      fr(1)=frho(qR(1),qR(2),qR(3),pR)
      fr(2)=frhou(qR(1),qR(2),qR(3),pR)
      fr(3)=fe(qR(1),qR(2),qR(3),pR)

      qM=0.5_KND*(qL+qR)-(0.5_KND/A)*(fr-fl)
      pM=(gamma-1._KND)*(qM(3)-0.5_KND*(qM(2)*qM(2))/qM(1))

      fM(1)=frho(qM(1),qM(2),qM(3),pM)
      fM(2)=frhou(qM(1),qM(2),qM(3),pM)
      fM(3)=fe(qM(1),qM(2),qM(3),pM)
      fM=0.25_KND*(fL+2*fM+fR-A*(qR-qL))
      if (l==MUSTAstages) then
       flrho(i)=fM(1)
       flrhou(i)=fM(2)
       fle(i)=fM(3)
       EXIT stg
      else
       !corrector step - opens Riemann fan
       qL=qL-(fM-fL)/A
       qR=qR-(fR-fM)/A
       pL=(gamma-1._KND)*(qL(3)-0.5_KND*(qL(2)*qL(2))/qL(1))
       pR=(gamma-1._KND)*(qR(3)-0.5_KND*(qR(2)*qR(2))/qR(1))
      endif
     enddo stg
    enddo

    !update differences
    drho(1)=flrho(1)/dx
    drhou(1)=flrhou(1)/dx
    de(1)=fle(1)/dx
    do i=2,nx
     drho(i-1)=drho(i-1)-flrho(i)/dx
     drhou(i-1)=drhou(i-1)-flrhou(i)/dx
     de(i-1)=de(i-1)-fle(i)/dx
     drho(i)=flrho(i)/dx
     drhou(i)=flrhou(i)/dx
     de(i)=fle(i)/dx
    enddo
    drho(nx)=drho(nx)-flrho(nx+1)/dx
    drhou(nx)=drhou(nx)-flrhou(nx+1)/dx
    de(nx)=de(nx)-fle(nx+1)/dx
   endsubroutine FLUXESMUSTA

   subroutine FDLF(rho,rhou,e)
    real(KND),dimension(-2:)::rho,rhou,e
    real(KND),dimension(LBOUND(rho,1):UBOUND(rho,1))::p,rho2,rhou2,e2
    real(KND) A
    integer i
    call BOUND(rho,rhou,e)
    do i=0,nx+1
        p(i)=(gamma-1._KND)*(e(i)-(1._KND/2._KND)*(rhou(i)*rhou(i))/rho(i))
        if ((p(i)<0).or.(p(i)<0)) write(*,*) "ERROR! pressure < 0",p(i)
    enddo

   A=(dt/dx)
   do i=1,nx
    rho2(i)=(rho(i-1)+rho(i+1))/2._KND&
            -A*(frho(rho(i+1),rhou(i+1),e(i+1),p(i+1))-frho(rho(i-1),rhou(i-1),e(i-1),p(i-1)))/2._KND
   rhou2(i)=(rhou(i-1)+rhou(i+1))/2._KND&
            -A*(frhou(rho(i+1),rhou(i+1),e(i+1),p(i+1))-frhou(rho(i-1),rhou(i-1),e(i-1),p(i-1)))/2._KND
   e2(i)=(e(i-1)+e(i+1))/2._KND&
            -A*(fe(rho(i+1),rhou(i+1),e(i+1),p(i+1))-fe(rho(i-1),rhou(i-1),e(i-1),p(i-1)))/2._KND
   enddo
   rho=rho2
   rhou=rhou2
   e=e2
   endsubroutine FDLF

   subroutine FDLW(rho,rhou,e)
    real(KND),dimension(-2:)::rho,rhou,e
    real(KND),dimension(LBOUND(rho,1):UBOUND(rho,1))::p,rho2,rhou2,e2
    real(KND) A
    integer i
    real(KND),PARAMETER:: eps=0.001
    call BOUND(rho,rhou,e)
    do i=0,nx+1
        p(i)=(gamma-1._KND)*(e(i)-(1._KND/2._KND)*(rhou(i)*rhou(i))/rho(i))
        if (p(i)<0) p=0
    enddo

   A=dt/dx
   do i=1,nx
    rho2(i)=(rho(i)+rho(i+1))/2._KND&
            -A*(frho(rho(i+1),rhou(i+1),e(i+1),p(i+1))-frho(rho(i),rhou(i),e(i),p(i)))/2._KND
    if (rho2(i)<eps) rho2(i)=eps
    rhou2(i)=(rhou(i)+rhou(i+1))/2._KND&
            -A*(frhou(rho(i+1),rhou(i+1),e(i+1),p(i+1))-frhou(rho(i),rhou(i),e(i),p(i)))/2._KND
    e2(i)=(e(i)+e(i+1))/2._KND&
            -A*(fe(rho(i+1),rhou(i+1),e(i+1),p(i+1))-fe(rho(i),rhou(i),e(i),p(i)))/2._KND
    if (e2(i)<eps) e2(i)=eps
   enddo

   call BOUND(rho2,rhou2,e2)
    do i=0,nx+1
        p(i)=(gamma-1._KND)*(e2(i)-(1._KND/2._KND)*(rhou2(i)*rhou2(i))/rho2(i))
        if (p(i)<0) p=0
    enddo

   do i=1,nx
    rho(i)=rho(i)-A*(frho(rho2(i),rhou2(i),e2(i),p(i))-frho(rho2(i-1),rhou2(i-1),e2(i-1),p(i-1)))
    if (rho(i)<eps) rho(i)=eps
    rhou(i)=rhou(i)-A*(frhou(rho2(i),rhou2(i),e2(i),p(i))-frhou(rho2(i-1),rhou2(i-1),e2(i-1),p(i-1)))
    e(i)=e(i)-A*(fe(rho2(i),rhou2(i),e2(i),p(i))-fe(rho2(i-1),rhou2(i-1),e2(i-1),p(i-1)))
    if (e(i)<eps) e(i)=eps
   enddo

   endsubroutine FDLW

   real(KND) function frho(rho,rhou,e,p)
    real(KND) rho,rhou,e,p
    frho=rhou
   endfunction frho

   real(KND) function frhou(rho,rhou,e,p)
    real(KND) rho,rhou,e,p
    frhou=rhou*rhou/rho+p
   endfunction frhou

   real(KND) function fe(rho,rhou,e,p)
    real(KND) rho,rhou,e,p
    fe=(rhou/rho)*(e+p)
    endfunction fe

  real(KND) function LIMITER(a,b)
  real(KND) a,b
  if (limitertype==1) then
     LIMITER=MINMOD(a,b)
   elseif (limitertype==2) then
     LIMITER=MINMOD(limparam*a,(a+b)/2._KND,limparam*b)
   elseif (limitertype==3) then
     LIMITER=SUPERBEE(a,b)
   endif

  endfunction LIMITER

  real(KND) function MINMOD2(a,b)
  real(KND) a,b
      MINMOD2=(SIGN(1._KND,a)+SIGN(1._KND,b))*MIN(ABS(a),ABS(b))/2._KND
  endfunction MINMOD2

  real(KND) function MINMOD3(a,b,c)
  real(KND) a,b,c
    if ((a>0._KND).and.(b>0._KND).and.(c>0._KND)) then
        MINMOD3=MIN(a,b,c)
    elseif ((a<0._KND).and.(b<0._KND).and.(c<0._KND)) then
        MINMOD3=MAX(a,b,c)
    else
        MINMOD3=0._KND
    endif
  endfunction MINMOD3

  real(KND) function SUPERBEE(a,b)
  real(KND) a,b,ab,b2

  ab=a*b
  b2=b*b
  if ((a*b)<=0._KND) then
   SUPERBEE=0._KND
  else if (limparam*ab<b2) then
   SUPERBEE=a*limparam
  else if (ab<b2) then
   SUPERBEE=b
  else if (ab<limparam*b2) then
   SUPERBEE=a
  else
   SUPERBEE=b*limparam
  endif
  endfunction SUPERBEE

  subroutine BOUND(rho,rhou,e)
   real(KND),dimension(-2:)::rho,rhou,e

   if (extype==1) then
    rho(-2:0)=rho(1)
    rho(nx+1:nx+3)=rho(nx)

    rhou(-2:0)=rhou(1)
    rhou(nx+1:nx+3)=rhou(nx)

    e(-2:0)=e(1)
    e(nx+1:nx+3)=e(nx)
   else
    rho(-2:0)=rho(nx-2:nx)
    rho(nx+1:nx+3)=rho(1:3)

    rhou(-2:0)=rhou(nx-2:nx)
    rhou(nx+1:nx+3)=rhou(1:3)

    e(-2:0)=e(nx-2:nx)
    e(nx+1:nx+3)=e(1:3)
   endif
  endsubroutine BOUND

integer function lowerIndex(xvalue, x, nx)
    integer nx,i
    real(KND) x(nx)
    real(KND) xvalue
     !print*,' '
    do i=2,nx-1
        if (xvalue < x(i)) exit
    end do
    lowerIndex = i-1
    return
endfunction lowerIndex

subroutine linearMesh(yp, r, n, y, ny)
!
! yp  locations of segment matching points (returns xp)
! r   relative stretching to be applied at matching points
! n   number of matching points (including end points)
! y   mesh coordinates (output)
! ny  number of mesh points
    integer n,ny,i,j
    real(KND) yp(n), r(n)
    real(KND) y(ny)
    real(KND)xp(n)
    real(KND)a,b,x

    xp(1) = 0.
    do i=2,n
        a = r(i-1)
        b = (r(i) - r(i-1)) / (yp(i) - yp(i-1))
        if (b == 0) then
            xp(i) = xp(i-1) + (1./a)*(yp(i) - yp(i-1))
        else
            xp(i) = xp(i-1) + (1./b)*log((a + b*(yp(i) - yp(i-1))) / a)
        end if
    end do

    do j=1,ny
        x = (j-1.)/(ny-1.)*xp(n)
        i = lowerIndex(x, xp, n)
        a = r(i)
        b = (r(i+1) - r(i)) / (yp(i+1) - yp(i))
        if (b == 0) then
            y(j) = yp(i) + a*(x - xp(i))
        else
            y(j) = yp(i) + (a/b)*(exp(b*(x - xp(i))) - 1.)
        end if
    end do

    ! Normalize xp-coordinates
    xp = xp / xp(n)

    ! Return xp-coordinates in yp
    yp = xp

    return

 endsubroutine linearMesh
endmodule CUEuler


module globals

  integer, parameter :: n=100, dim=3
  real(8), parameter :: pi=3.14159265359, e0=8.854187817d-12, dt=1.0d-4, &
       q=1.6d-19, m=9.11d-31, delta=1.0d-8

  type particle
     real(8) :: m, q
     real(8), dimension(dim) :: a, s, v
  end type particle

end module globals

module misc

  use globals

contains

  subroutine init(particles)
    type(particle), dimension(:) :: particles

    integer :: n, i

    n = size(particles)

    do i=1, n
       particles(i)%m = m
       particles(i)%q = q
       particles(i)%a = 0
       particles(i)%v = 0

       call random_number(particles(i)%s)
    end do

  end subroutine init

  subroutine acc(p1, p2)
    type(particle) :: p1, p2

    real(8) :: d
    real(8), dimension(3) :: r

    r = p2%s - p1%s
    d = max(sqrt(sum(r**2)), delta)

    p1%a = p1%a  - 0.25d0*p1%q*p2%q*r/p1%m/e0/pi/d**3

  end subroutine acc

  subroutine vel(p)
    type(particle) :: p

    p%v = p%v + p%a*dt

  end subroutine vel

  subroutine dis(p)
    type(particle) :: p

    p%s = p%s + p%v*dt + 0.5d0*p%a*dt**2

  end subroutine dis

  function pote(p1, p2) result(e)
    type(particle) :: p1, p2
    real(8) :: e, d
    real(8), dimension(dim) :: r

    r = p2%s-p1%s
    d = max(sqrt(sum(r**2)), delta)
    e = 0.25d0*p1%q*p2%q/e0/pi/d

  end function pote

  function kine(p) result(e)
    type(particle) :: p
    real(8) :: e

    e = 0.5*p%m*sum(p%v**2)

  end function kine

  subroutine bounds(p)
    type(particle) :: p

    where(p%s(:) < 0.0d0)
       p%s(:) = -p%s(:)
       p%v(:) = -p%v(:)
    end where

    where(p%s(:) > 1.0d0)
       p%s(:) = 2.0d0-p%s(:)
       p%v(:) = -p%v(:)
    end where
  end subroutine bounds

end module misc

program nbody

  use globals
  use misc

  implicit none

  type(particle), dimension(n) :: particles
  integer :: i, j
  real(8) :: t, e, twrite

  call init(particles)

  t = 0.0d0
  twrite = 0.0d0

  do while ( t < 1.0d0)

     e = 0.0d0

     do j = 1, n
        particles(j)%a = 0.0d0
        e = e + kine(particles(j))

        do i = 1, n
           call acc(particles(j), particles(i))
           e = e + pote(particles(j), particles(i))
        end do
     end do

     do j = 1, n
        call vel(particles(j))
        call dis(particles(j))
        call bounds(particles(j))
     end do

     t = t + dt

     if (t > twrite) then
        write(*,*) e
        twrite = t+0.1d0
     end if
  end do
end program nbody


module matrix_module
real(kind=8), allocatable :: a2(:,:)
real(kind=8), allocatable :: b2(:,:)
real(kind=8), allocatable :: c2(:,:)
integer matrix_size
end module

subroutine sub_initialize
	use matrix_module
	parameter (MAX_MATRIX=15000)
	integer(kind=8) i8n

	matrix_size=MAX_MATRIX
	n = matrix_size
	i8n = (n/1000)*(n/1000)*8*3
	allocate (a2(n,n), b2(n,n), c2(n,n), stat=ierr)
	write(*,*) "<sub_initialize> allocating", i8n, " MB of memory"
	if(ierr.eq.0) then
		write(*,*) "<allocate> was successful"
	else
		write(*,*) "*** Error. <allocate> failed: ierr=", ierr
	endif
!$omp parallel
!$omp do
	do j=1, n
	do i=1, n
	a2(i,j) = 1.0
	b2(i,j) = 2.0
	c2(i,j) = 3.0
	end do
	end do
!$omp end do
!$omp end parallel
	return
end

subroutine sub_dgemm
	use matrix_module
	real(kind=8) :: one, x

!cx	write(*,*) "<sub_dgemm> matrix size:", matrix_size

	if(.true.) then
	n = matrix_size
	one = 1.0
	call dgemm ("N", "N", n, n, n, one, a2, n, b2, n, one, c2, n)

	else
!$omp parallel
!$omp do private(x)
	do j=1, n
	do i=1, n
	x = 0.0
	do k=1, n
	x = x + a2(i,k)*b2(k,j)
	end do
	c2(i,j) = x
	end do
	end do
!$omp end do
!$omp end parallel
	endif
	return
end


FUNCTION hermite(npt, func, ier) RESULT(fn_val)

!       HERMITE INTEGRATION, I.E. EVALUATION OF THE INTEGRAL OF
!       exp(-x**2)*f(x) FROM -INFINITY TO +INFINITY

!       NPT     = INPUT, NO. OF POINTS AT WHICH f(x) IS TO BE EVALUATED.
!                 NPT MUST BE ONE OF 2, 4, 6, 8, 10, 12, 16, 20.
!       FUNC    = INPUT, NAME OF THE USER'S FUNCTION TO SUPPLY VALUES
!                 OF F(X).   THE FUNCTION MAY HAVE ANY NAME BUT ONLY THE
!                 ONE ARGUMENT, X.
!       IER     = OUTPUT, ERROR INDICATOR
!                   = 0 NO ERROR DETECTED
!                   = 1 ILLEGAL VALUE OF NPT

!       LATEST REVISION - 5 December 1999

!************************************************************************

IMPLICIT NONE
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)  :: npt
INTEGER, INTENT(OUT) :: ier
REAL (dp)            :: fn_val

INTERFACE
  FUNCTION func(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN) :: x
    REAL (dp)             :: fn_val
  END FUNCTION func
END INTERFACE

!     Local variables

REAL (dp) :: xpt(39) = (/ 0.707106781186548_dp, &
               0.524647623275290_dp, 1.650680123885785_dp, &
               0.436077411927617_dp, 1.335849074013697_dp, 2.350604973674492_dp, &
               0.381186990207322_dp, 1.157193712446780_dp, 1.981656756695843_dp, &
               2.930637420257244_dp, &
               0.342901327223705_dp, 1.036610829789514_dp, 1.756683649299882_dp, &
               2.532731674232790_dp, 3.436159118837738_dp, &
               0.314240376254359_dp, 0.947788391240164_dp, 1.597682635152605_dp, &
               2.279507080501060_dp, 3.020637025120890_dp, 3.889724897869782_dp, &
               0.27348104613815_dp,  0.82295144914466_dp, 1.38025853919888_dp, &
               1.95178799091625_dp,  2.54620215784748_dp, 3.17699916197996_dp, &
               3.86944790486012_dp,  4.68873893930582_dp, &
               0.2453407083009_dp,   0.7374737285454_dp, 1.2340762153953_dp, &
               1.7385377121166_dp,   2.2549740020893_dp, 2.7888060584281_dp, &
               3.3478545673832_dp,   3.9447640401156_dp, 4.6036824495507_dp, &
               5.3874808900112_dp /),                                    &
   wt(39) = (/ 8.862269254528D-1, &
               8.049140900055D-1, 8.131283544725D-2, &
               7.246295952244D-1, 1.570673203229D-1, 4.530009905509D-3, &
               6.611470125582D-1, 2.078023258149D-1, 1.707798300741D-2, &
               1.996040722114D-4, &
               6.108626337353D-1, 2.401386110823D-1, 3.387439445548D-2, &
               1.343645746781D-3, 7.640432855233D-6, &
               5.701352362625D-1, 2.604923102642D-1, 5.160798561588D-2, &
               3.905390584629D-3, 8.573687043588D-5, 2.658551684356D-7, &
               5.079294790166D-1, 2.806474585285D-1, 8.381004139899D-2, &
               1.288031153551D-2, 9.322840086242D-4, 2.711860092538D-5, &
               2.320980844865D-7, 2.654807474011D-10, &
               4.622436696006D-1, 2.866755053628D-1, 1.090172060200D-1, &
               2.481052088746D-2, 3.243773342238D-3, 2.283386360163D-4, &
               7.802556478532D-6, 1.086069370769D-7, 4.399340992273D-10, &
               2.229393645534D-13 /), zero = 0.0_dp, x
INTEGER  :: npts(8) = (/ 2, 4, 6, 8, 10, 12, 16, 20 /), ipos, i, nby2

!       CHECK FOR PERMISSIBLE VALUE OF NPT.

fn_val = zero
ipos = 1
DO i = 1, 8
  IF(npts(i).EQ.npt) GO TO 20
  ipos = ipos + (npts(i) + 1)/2
END DO
ier = 1
RETURN

!       EVALUATE SUM OF WT(I) * FUNC(X(I))

20 nby2 = (npt + 1)/2
DO i = 1, nby2
  x = xpt(ipos)
  fn_val = fn_val + wt(ipos) * (func(x) + func(-x))
  ipos = ipos + 1
END DO
ier = 0
RETURN

END FUNCTION hermite


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     6/98
c
c     a program for testing all vorticity and ivnerse vorticity routines
c
c
c     (1) first set a stream function and velocity potential scalar fields as
c         polys in x,y,z restricted to the sphere
c
c     (2) derive a vector field (v,w) from (1)
c
c     (3) compute the vorticity vt of (2) and compare with the vorticity
c         computed analytically
c
c     (4) compute vector field (ve,we) using br,bi,cr,ci from (v,w) with
c         br=bi=0.0
c
c     (5) invert the vorticity in (3) and compare with (4)
c

      program tvrt
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 24,nnlon= 14, nnt = 3)
      parameter (mmdab = (nnlon+2)/2, mmdc = (nnlon+1)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav=5*nnlat*nnlat*nnlon)
      dimension work(lleng),wsave(llsav)
      parameter (lldwork = 4*nnlat*nnlat)
      dimension dwork(lldwork)
      dimension br(mmdc,nnlat,nnt),bi(mmdc,nnlat,nnt)
      dimension cr(mmdc,nnlat,nnt),ci(mmdc,nnlat,nnt)
      dimension a(mmdab,nnlat,nnt),b(mmdab,nnlat,nnt)
      dimension vt(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension ve(nnlat,nnlon,nnt),we(nnlat,nnlon,nnt)
      dimension pertrb(nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      nmax = max0(nlat,nlon)
      mdab = mmdab
      mdc = mmdc
      lwork = lleng
      lsave = llsav
      ldwork = lldwork
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all vorticity subroutines
c
      do icase=1,4
      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c
c     set scalar stream and velocity potential fields as polys in x,y,z
c     and then set v,w from st,sv scalar fields
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    dxdp = -sint*sinp
	    dydt = cost*sinp
	    dydp = sint*cosp
	    dzdt = -sint
	    dzdp = 0.0
	    if (k.eq.1) then
c              st(i,j,k) = x
c              sv(i,j,k) = y
c
c          v = -1/sin(theta)*dstdp + dsvdt
c
c          w =  1/sin(theta)*dsvdp + dstdt
c
	       v(i,j,k) = sinp + cost*sinp
	       w(i,j,k) = cosp + cost*cosp
	       vt(i,j,k) = -2.0*sint*cosp
	    else if (k.eq.2) then
C              st = y
c              sv = z
	       v(i,j,k) = -cosp-sint
	       w(i,j,k) = cost*sinp
c         sint*vt = -dvdp + sint*dwdt + cost*w
c                 = sinp + sint*(-sint*sinp)+cost*cost*sinp
c                 = sinp + (cost**2-sint**2)*sinp
	       vt(i,j,k) = -2.*sint*sinp
	    else if (k.eq.3) then
c           st = x
c           sv = z
	    v(i,j,k) = sinp - sint
	    w(i,j,k) = cost*cosp
c     sint*vt = -cosp-sint*sint*sinp+cost*cost*cosp
c             = -cosp + (1-2.*sint**2)*cosp =
	    vt(i,j,k) = -2.*sint*cosp
	    end if
	  end do
	end do
      end do

c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     call aout(vt(1,1,kk),"  vt",nlat,nlon)
c     end do

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze vector field
c
      call vhaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdc,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(br(1,1,kk),"  br",mdc,nlat)
c     call aout(bi(1,1,kk),"  bi",mdc,nlat)
c     call aout(cr(1,1,kk),"  cr",mdc,nlat)
c     call aout(ci(1,1,kk),"  ci",mdc,nlat)
c     end do
c     end if
c
c     compute vorticity of (v,w) in vt
c

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name("vrti")
      call iout(ierror,"ierr")

      call vrtec(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdc,nlat,
     +wsave,lsave,work,lwork,ierror)

      call name("vrt ")
      call iout(ierror,"ierr")
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")

      else if (icase.eq.2) then

      call name("**es")
      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)

      call name("vrti")
      call iout(ierror,"ierr")

      call vrtes(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdc,nlat,
     +wsave,lsave,work,lwork,ierror)

      call name("vrt ")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call name("**gc")

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)

      call name("vrti")
      call iout(ierror,"ierr")

      call vrtgc(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdc,nlat,
     +wsave,lsave,work,lwork,ierror)

      call name("vrt ")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)

      call name("vrti")
      call iout(ierror,"ierr")

      call vrtgs(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdc,nlat,
     +wsave,lsave,work,lwork,ierror)

      call name("vrt ")
      call iout(ierror,"ierr")
      end if

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(vt(1,1,kk),"  vt",nlat,nlon)
c     end do
c     end if
c
c     compute "error" in vt
c
      err2 = 0.0
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    dxdt = cost*cosp
	    d2xdt2 = -sint*cosp
	    dxdp = -sint*sinp
	    d2xdp2 = -sint*cosp
	    dydt = cost*sinp
	    d2ydt2 = -sint*sinp
	    dydp = sint*cosp
	    d2ydp2 = -sint*sinp
	    dzdt = -sint
	    d2zdt2 = -cost
	    dzdp = 0.0
	    d2zdp2 = 0.0
	    if (k.eq.1) then
	       vte = -2.0*sint*cosp
	    else if (k.eq.2) then
	       vte = -2.*sint*sinp
	    else if (k.eq.3) then
	    vte = -2.*sint*cosp
	    end if
	       err2 = err2 + (vt(i,j,k)-vte)**2
	  end do
	end do
      end do
      err2 = sqrt(err2/(nt*nlat*nlon))
      call vout(err2,"err2")
c
c     now recompute (v,w) inverting vt using ivrt(ec,es,gc,gs)
c     and compare with (ve,we) generated by synthesizing br,bi,cr,ci
c     with br=bi=0.0
c

      do k=1,nt
	do i=1,mdc
	  do j=1,nlat
	    br(i,j,k) = 0.0
	    bi(i,j,k) = 0.0
	  end do
	end do
      end do

      if (icase.eq.1) then

      call name("**ec")

c
c     set vector field (ve,we) with br=bi=0.0 for comparison with inverted vt
c
      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsec(nlat,nlon,ityp,nt,ve,we,nlat,nlon,br,bi,cr,ci,
     +           mdc,nlat,wsave,lsave,work,lwork,ierror)

      call name("vhs ")
      call iout(ierror,"ierr")

      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaec(nlat,nlon,isym,nt,vt,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(a(1,1,kk),"   a",nlat,nlat)
c     call aout(b(1,1,kk),"   b",nlat,nlat)
c     end do
c     end if

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call ivrtec(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("ivrt")
      call iout(ierror,"ierr")
      call vout(pertrb,"prtb")

      else if (icase.eq.2) then

      call name("**es")
c
c     set vector field (ve,we) with br=bi=0.0 for comparison with inverted vt
c
      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhses(nlat,nlon,ityp,nt,ve,we,nlat,nlon,br,bi,cr,ci,
     +           mdc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vhs ")
      call iout(ierror,"ierr")

      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaes(nlat,nlon,isym,nt,vt,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("ivti")
      call iout(ierror,"ierr")

      call ivrtes(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("ivrt")
      call iout(ierror,"ierr")
      call vout(pertrb,"prtb")

      else if (icase.eq.3) then

      call name("**gc")
c
c     set vector field (ve,we) with br=bi=0.0 for comparison with inverted vt
c
      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsgc(nlat,nlon,ityp,nt,ve,we,nlat,nlon,br,bi,cr,ci,
     +           mdc,nlat,wsave,lsave,work,lwork,ierror)

      call name("vhs ")
      call iout(ierror,"ierr")

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shagc(nlat,nlon,isym,nt,vt,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("ivti")
      call iout(ierror,"ierr")

      call ivrtgc(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)

      call name("ivrt")
      call iout(ierror,"ierr")
      call vout(pertrb,"prtb")

      else if (icase.eq.4) then

      call name("**gs")
c
c     set vector field (ve,we) with br=bi=0.0 for comparison with inverted vt
c
      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhsi")
      call iout(ierror,"ierr")

      call vhsgs(nlat,nlon,ityp,nt,ve,we,nlat,nlon,br,bi,cr,ci,
     +           mdc,nlat,wsave,lsave,work,lwork,ierror)
      call name("vhs ")
      call iout(ierror,"ierr")

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shags(nlat,nlon,isym,nt,vt,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("ivti")
      call iout(ierror,"ierr")

      call ivrtgs(nlat,nlon,isym,nt,v,w,nlat,nlon,a,b,
     +mdab,nlat,wsave,lsave,work,lwork,pertrb,ierror)
      call name("ivrt")
      call iout(ierror,"ierr")
      call vout(pertrb,"prtb")

      end if

c     if (nmax.lt.10) then
c     do kk=1,nt
c     call iout(kk,"**kk")
c     call aout(v(1,1,kk),"   v",nlat,nlon)
c     call aout(w(1,1,kk),"   w",nlat,nlon)
c     end do
c     end if

c
c     compare this v,w with ve,we
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    err2v = err2v + (v(i,j,k)-ve(i,j,k))**2
	    err2w = err2w + (w(i,j,k)-we(i,j,k))**2
	  end do
	end do
      end do
      err2v = sqrt(err2v/(nlat*nlon*nt))
      err2w = sqrt(err2w/(nlat*nlon*nt))
      call vout(err2v,"errv")
      call vout(err2w,"errw")
c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


subroutine rroot (n, r0, a, nr, r)

!   Finds a single arbitrary-precision real root, beginning at r0.
!   Modified for the toolkit.
!   David H Bailey   2004-05-27

use mpmodule
use globdata
implicit none
integer i, j, k, n, nit, nr, nwp
parameter (nit = 100)
type (mp_real) a(0:n), ad(0:n-1), eps1
type (mp_real) t1, t2, t3, t4, r, r0

!   Compute derivative.

do i = 0, n - 1
  ad(i) = (i + 1) * a(i+1)
enddo

nwp = 3
call mpsetprecwords (nwp)
t1 = r0
t2 = 0.d0
if (r0 /= t2) then
  eps1 = 2.d0 ** (-96) * abs (t1)
else
  eps1 = 2.d0 ** (-96)
endif

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at t1.

  t2 = 0.d0

  do i = n, 0, -1
    t2 = t1 * t2 + a(i)
  enddo

!   Evaluate polynomial derivative at t1.

  t3 = 0.d0

  do i = n - 1, 0, -1
    t3 = t1 * t3 + ad(i)
  enddo

  t4 = t1 - t2 / t3
  if (nwp == 3) then
    if (abs (t1 - t4) < eps1) then
      nwp = min (2 * nwp - 1, nwords1)
      call mpsetprecwords (nwp)
    endif
  elseif (nwp < nwords1) then
    nwp = min (2 * nwp - 1, nwords1)
    call mpsetprecwords (nwp)
  else
    t1 = t4
    goto 100
  endif
  t1 = t4
enddo

write (6, 1)
1 format ('rroot: failed to find arbitrary precision real root.')
nr = 0
r = 0.d0
goto 110

100 continue

nr = 1
r = t1

110 continue

call mpsetprecwords (nwords1)
return
end

subroutine croot (n, r0, a, nr, r)

!   Finds a single arbitrary-precision complex root, beginning at r0.

use mpmodule
use globdata
implicit none
integer i, j, k, n, nit, nr, nwp
parameter (nit = 100)
type (mp_real) a(0:n), ad(0:n-1), eps1
type(mp_complex) t1, t2, t3, t4, r, r0

!   Compute derivative.

do i = 0, n - 1
  ad(i) = (i + 1) * a(i+1)
enddo

nwp = 3
call mpsetprecwords (nwp)
t1 = r0
t2 = (0.d0, 0.d0)
if (r0 /= t2) then
  eps1 = 2.d0 ** (-96) * abs (t1)
else
  eps1 = 2.d0 ** (-96)
endif

!   Perform up to nit double-precision Newton iterations.

do j = 1, nit

!   Evaluate polynomial at t1.

  t2 = (0.d0, 0.d0)

  do i = n, 0, -1
    t2 = t1 * t2 + a(i)
  enddo

!   Evaluate polynomial derivative at t1.

  t3 = (0.d0, 0.d0)

  do i = n - 1, 0, -1
    t3 = t1 * t3 + ad(i)
  enddo

  t4 = t1 - t2 / t3
  if (nwp == 3) then
    if (abs (t1 - t4) < eps1) then
      nwp = min (2 * nwp - 1, nwords1)
      call mpsetprecwords (nwp)
    endif
  elseif (nwp < nwords1) then
    nwp = min (2 * nwp - 1, nwords1)
    call mpsetprecwords (nwp)
  else
    t1 = t4
    goto 100
  endif
  t1 = t4
enddo

write (6, 1)
1 format ('croot: failed to find multiple precision complex root.')
nr = 0
r = (0.d0, 0.d0)
goto 110

100 continue

nr = 1
r = t1

110 continue

call mpsetprecwords (nwords1)
return
end


   program main
      use debugging
      use matrices

      implicit none
      integer :: NN, dmn, N_max,N_min,ii,jj
      integer, allocatable :: seed(:)
      double precision ::  start, finish, f, s
      double complex, allocatable :: matrix(:,:), O(:), Odag(:)

      ! Seeding
      call random_seed(size=NN)
      allocate(seed(NN))
      seed = 10
      call random_seed(put=seed)

      ! Parameters
      print *, "Insert N_max:"
      read *, N_max
      print *, "Insert N_min:"
      read *, N_min

      if(N_min>N_max) then
         print *, "Error: Invalid limits."
         stop
      end if

      ! Open diagonalization file
      open(10,file="data/diagonalization.txt", status="unknown", access="append")

      call cpu_time(s)

      do dmn=N_min,N_max
         allocate(matrix(dmn,dmn))
         allocate(O(dmn))
         allocate(Odag(dmn))
         O = complex(1d0,2d0)
         Odag = conjg(O)
         do ii=1,dmn
            do jj=1,dmn
               matrix(ii,jj) = Odag(ii)*O(jj)
               if(ii.eq.jj) then
                  matrix(ii,ii) = matrix(ii,ii) +0.0001
               endif

            enddo
         enddo

         call cpu_time(start)
         call inv_herm(matrix)
         call cpu_time(finish)
         write(10,*) dmn, finish-start
         deallocate(matrix, O,Odag)

      enddo

      call cpu_time(f)

      close(10)

      print *, "Total computation time (s):", f-s

    end program main


subroutine para3d(X, n, m, l, ndim, S, u, v, w)
  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract para3d calculates the parametric locations for a 3d block
  !
  !     Description of Arguments

  !     Input
  !     X       - Real, size(ndim, l, m, n): Coordiantes

  !     Output
  !     S       - Real, size(ndim, l, m, n): The u, v, w parametric positions
  !     u       - Real, size(n): The averaged u parameters
  !     v       - Real, size(m): The averaged v parameters
  !     w       - Real, size(l): The averaged w parameters

  use precision
  implicit none

  ! Input
  integer          , intent(in)   :: n, m, l, ndim
  real(kind=realType) , intent(in)   :: X(ndim, l, m, n)

  ! Output
  real(kind=realType) , intent(out)  :: S(ndim, l, m, n)
  real(kind=realType) , intent(out)  :: u(n), v(m), w(l)

  ! Working
  integer                         :: i, j, k

  real(kind=realType) DELI, DELJ, DELK

  DELI(K, J, I) = SQRT ((X(1, K, J, I) - X(1, K, J, I-1)) ** 2 + &
                      (X(2, K, J, I) - X(2, K, J, I-1)) ** 2 + &
                      (X(3, K, J, I) - X(3, K, J, I-1)) ** 2)

  DELJ(K, J, I) = SQRT ((X(1, K, J, I) - X(1, K, J-1, I)) ** 2 + &
                      (X(2, K, J, I) - X(2, K, J-1, I)) ** 2 + &
                      (X(3, K, J, I) - X(3, K, J-1, I)) ** 2)

  DELK(K, J, I) = SQRT ((X(1, K, J, I) - X(1, K-1, J, I)) ** 2 + &
                      (X(2, K, J, I) - X(2, K-1, J, I)) ** 2 + &
                      (X(3, K, J, I) - X(3, K-1, J, I)) ** 2)

  u(:) = 0.0
  v(:) = 0.0
  w(:) = 0.0

  !     Zero the three low-end faces (or edges if one plane is specified).

  S(1, :, :, 1) = 0.0
  S(2, :, 1, :) = 0.0
  S(3, 1, :, :) = 0.0

  !     Set up the low-end edge lines because they are missed by the
  !     following loops over most of the low-end faces:

  DO I=2, n
     S(1, 1, 1, I) = S(1, 1, 1, I-1) + DELI(1, 1, I)
  END DO

  DO J=2, m
     S(2, 1, J, 1) = S(2, 1, J-1, 1) + DELJ(1, J, 1)
  END DO

  DO K=2, l
     S(3, K, 1, 1) = S(3, k-1, 1, 1) + DELK(K, 1, 1)
  END DO

  !     Set up the rest of the low-end face lines because they are
  !     missed by the the main loop over most of the volume.

  DO K=2, l
     DO J=2, m
        S(2, K, J, 1) = S(2, K, J-1,  1) + DELJ(K, J, 1)
        S(3, K, J, 1) = S(3, K-1, J, 1) + DELK(K, J, 1)
     END DO
  end DO

  DO I=2, n
     DO K=2, l
        S(1, K, 1, I) = S(1, K  , 1, I-1) + DELI(K, 1, I)
        S(3, K, 1, I) = S(3, K-1, 1, I  ) + DELK(K, 1, I)
     END DO

  END DO

  DO I=2, n
     DO J=2, m
        S(1, 1, J, I) = S(1, 1, J, I-1) + DELI(1, J, I)
        S(2, 1, J, I) = S(2, 1, J-1, I) + DELJ(1, J, I)
     END DO
  END DO

  !     Traverse the block just once for all lines except those within
  !     the low-end faces.

  DO I=2, n
     DO J=2, m
        DO K=2, l
           S(1, K, J, I) = S(1, K, J, I-1) + DELI(K, J, I)
           S(2, K, J, I) = S(2, K, J-1, I) + DELJ(K, J, I)
           S(3, K, J, I) = S(3, K-1, J, I) + DELK(K, J, I)
        END DO
     END DO
  END DO

  !     Normalizing requires another pass through the volume.
  !     Handle lines of zero length first by inserting uniform
  !     distributions.  Then the standard normalization can be
  !     applied safely everywhere.

  DO J=1, m
     !        Zero-length lines in the I direction?

     DO K=1, l
        IF (S(1, K, J, n) == 0.0) THEN
           DO I=2, n
              S(1, K, J, I) = I-1
           END DO
        END IF
     END DO
  end DO

  !        Zero-length lines in the J direction?
  DO I=1, n
     DO K=1, l
        IF (S(2, K, m, I) == 0.0) THEN
           DO J=2, m
              S(2, K, J, I) = J-1
           END DO
        END IF
     END DO
  END DO

  !     Zero-length lines in the K direction?

  DO I=1, n
     DO J=1, m
        IF (S(3, l, J, I) == 0.0) THEN
           DO K=2, l
              S(3, K, J, I) = K-1
           END DO
        END IF
     END DO
  END DO

  !     Normalize:

  DO I=1, n
     DO J=1, m
        DO K=1, l
           S(1, K, J, I) = S(1, K, J, I) / S(1, K, J, N)
           S(2, K, J, I) = S(2, K, J, I) / S(2, K, M, I)
           S(3, K, J, I) = S(3, K, J, I) / S(3, L, J, I)
        END DO
     END DO
  END DO

  !     Finally, precise 1s for the three high-end faces:

  DO J=1, m
     DO K=1, l
        S(1, K, J, n) = 1.0
     END DO
  end DO

  DO I=1, n
     DO K=1, l
        S(2, K, M, I) = 1.0
     END DO
  END DO

  DO I=1, n
     DO J=1, m
        S(3, L, J, I) = 1.0
     END DO
  END DO

  ! Now get an average u, v, w

  ! Average u

  do j=1, m
     do k=1, l
        u = u + S(1, k, j, :)
     end do
  end do
  u = u/(l*m)

  ! Average v
  do i=1, n
     do k=1, l
        v = v + S(2, k, :, i)
     end do
  end do
  v = v/(n*l)

  ! Average w
  do i=1, n
     do j=1, m
        w = w + S(3, :, j, i)
     end do
  end do
  w = w/(n*m)

end subroutine para3d