subroutine tridiagxvector(ad, al, au, v, w)

implicit none

real(8), dimension(:), intent(in) :: ad, al, au, v
real(8), dimension(:), intent(out) :: w

integer:: n

n = size(ad)

w = 0

w(1:n) = ad*v(1:n)
w(1:n-1)=w(1:n-1) + au*v(2: n)
w(2:n) = w(2:n) + al*v(1:n-1)

print*,
print*, 'Tridiag: ', w
print*,

end subroutine


program OOParticlesAndFieldTest

use NumberKindsModule
use LoggerModule
use UtilitiesModule
use ParticlesOOModule
use FieldOOModule

implicit none

integer(kint) :: i, j
type(Logger) :: exeLog
type(Field) :: scalarField
type(Field) :: vectorField
type(Particles) :: aParticles

real(kreal), parameter :: dx = 0.1_kreal
real(kreal), parameter :: xmin = -5.0_kreal
real(kreal), parameter :: xmax = 5.0_kreal
real(kreal), parameter :: ymin = xmin
real(kreal), parameter :: ymax = xmax
integer(kint), parameter :: nn = 101

real(kreal), dimension(2) :: vec

character(len=56) :: logkey = "ParticlesAndFieldTest"
character(len=256) :: logstring

call New(exeLog, DEBUG_LOGGING_LEVEL)
write(logstring,'(A,I4,A,I4,A)') "part 1: build a particle set from an ", nn, " x ", nn, " uniform grid."
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", trim(logstring))
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", "part 2: define a scalar field on the particles")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", "part 3: define a vector field on the particles")
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" ", "part 4: output particles and fields to matlab m file.")

call aParticles%init(nn*nn, PLANAR_GEOM)

do i=1,nn
    vec(1) = xmin + dx * (i-1)
    do j=1,nn
        vec(2) = ymin + dx *(j-1)
        call aParticles%insert(vec, vec)
    enddo
enddo

call aparticles%logstats(exeLog)

call scalarField%init(1, aParticles%N, "sineWave")
do i=1, aParticles%N
    call scalarField%insertScalar(sineWave([aParticles%x(i), aParticles%y(i)]))
enddo
call scalarField%logStats(exeLog)

call vectorField%init(2, aParticles%N, "gradSineWave")
do i=1, aParticles%N
    call vectorField%insertVector(sineWaveGrad([aParticles%x(i), aParticles%y(i)]))
enddo
call vectorField%logStats(exeLog)

open(unit=WRITE_UNIT_1, file='ooParticlesAndFieldTest.m', action='write', status='replace')
call aParticles%writeMatlab(WRITE_UNIT_1)
call scalarField%writeMatlab(WRITE_UNIT_1)
call vectorField%writeMatlab(WRITE_UNIT_1)
close(WRITE_UNIT_1)

if (testPass) call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" result: ", "PASSED.")

contains

pure function sineWave(xy)
    real(kreal) :: sineWave
    real(kreal), dimension(2), intent(in) :: xy
    sineWave = sin(2.0_kreal*PI* xy(1)/5.0_kreal) * sin(2.0_kreal*PI*xy(2)/5.0_kreal)
end function

pure function sineWaveGrad(xy)
    real(kreal), dimension(2) :: sineWaveGrad
    real(kreal), dimension(2), intent(in) :: xy

    sinewaveGrad(1) = 2.0_kreal*PI/5.0_kreal * cos(2.0_kreal*PI*xy(1)/5.0_kreal) * sin(2.0_kreal*PI*xy(2)/5.0_kreal)
    sinewaveGrad(2) = 2.0_kreal*PI/5.0_kreal * sin(2.0_kreal*PI*xy(1)/5.0_kreal) * cos(2.0_kreal*PI*xy(2)/5.0_kreal)
end function

end program


*DECK INVIT
      SUBROUTINE INVIT (NM, N, A, WR, WI, SELECT, MM, M, Z, IERR, RM1,
     +   RV1, RV2)
C***BEGIN PROLOGUE  INVIT
C***PURPOSE  Compute the eigenvectors of a real upper Hessenberg
C            matrix associated with specified eigenvalues by inverse
C            iteration.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C2B
C***TYPE      SINGLE PRECISION (INVIT-S, CINVIT-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure INVIT
C     by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C     This subroutine finds those eigenvectors of a REAL UPPER
C     Hessenberg matrix corresponding to specified eigenvalues,
C     using inverse iteration.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the upper Hessenberg matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        WR and WI contain the real and imaginary parts, respectively,
C          of the eigenvalues of the Hessenberg matrix.  The eigenvalues
C          must be stored in a manner identical to that output by
C          subroutine  HQR,  which recognizes possible splitting of the
C          matrix.  WR and WI are one-dimensional REAL arrays,
C          dimensioned WR(N) and WI(N).
C
C        SELECT specifies the eigenvectors to be found. The
C          eigenvector corresponding to the J-th eigenvalue is
C          specified by setting SELECT(J) to .TRUE.  SELECT is a
C          one-dimensional LOGICAL array, dimensioned SELECT(N).
C
C        MM should be set to an upper bound for the number of
C          columns required to store the eigenvectors to be found.
C          NOTE that two columns are required to store the
C          eigenvector corresponding to a complex eigenvalue.  One
C          column is required to store the eigenvector corresponding
C          to a real eigenvalue.  MM is an INTEGER variable.
C
C     On OUTPUT
C
C        A and WI are unaltered.
C
C        WR may have been altered since close eigenvalues are perturbed
C          slightly in searching for independent eigenvectors.
C
C        SELECT may have been altered.  If the elements corresponding
C          to a pair of conjugate complex eigenvalues were each
C          initially set to .TRUE., the program resets the second of
C          the two elements to .FALSE.
C
C        M is the number of columns actually used to store the
C          eigenvectors.  M is an INTEGER variable.
C
C        Z contains the real and imaginary parts of the eigenvectors.
C          The eigenvectors are packed into the columns of Z starting
C          at the first column.  If the next selected eigenvalue is
C          real, the next column of Z contains its eigenvector.  If the
C          eigenvalue is complex, the next two columns of Z contain the
C          real and imaginary parts of its eigenvector, with the real
C          part first.  The eigenvectors are normalized so that the
C          component of largest magnitude is 1. Any vector which fails
C          the acceptance test is set to zero.  Z is a two-dimensional
C          REAL array, dimensioned Z(NM,MM).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          -(2*N+1)   if more than MM columns of Z are necessary
C                     to store the eigenvectors corresponding to
C                     the specified eigenvalues (in this case, M is
C                     equal to the number of columns of Z containing
C                     eigenvectors already computed),
C          -K         if the iteration corresponding to the K-th
C                     value fails (if this occurs more than once, K
C                     is the index of the last occurrence); the
C                     corresponding columns of Z are set to zero
C                     vectors,
C          -(N+K)     if both error situations occur.
C
C        RM1 is a two-dimensional REAL array used for temporary storage.
C          This array holds the triangularized form of the upper
C          Hessenberg matrix used in the inverse iteration process.
C          RM1 is dimensioned RM1(N,N).
C
C        RV1 and RV2 are one-dimensional REAL arrays used for temporary
C          storage.  They hold the approximate eigenvectors during the
C          inverse iteration process.  RV1 and RV2 are dimensioned
C          RV1(N) and RV2(N).
C
C     The ALGOL procedure GUESSVEC appears in INVIT in-line.
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C     Calls CDIV for complex division.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  CDIV, PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  INVIT
C
      INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR
      REAL A(NM,*),WR(*),WI(*),Z(NM,*)
      REAL RM1(N,*),RV1(*),RV2(*)
      REAL T,W,X,Y,EPS3
      REAL NORM,NORMV,GROWTO,ILAMBD,RLAMBD,UKROOT
      REAL PYTHAG
      LOGICAL SELECT(N)
C
C***FIRST EXECUTABLE STATEMENT  INVIT
      IERR = 0
      UK = 0
      S = 1
C     .......... IP = 0, REAL EIGENVALUE
C                     1, FIRST OF CONJUGATE COMPLEX PAIR
C                    -1, SECOND OF CONJUGATE COMPLEX PAIR ..........
      IP = 0
      N1 = N - 1
C
      DO 980 K = 1, N
         IF (WI(K) .EQ. 0.0E0 .OR. IP .LT. 0) GO TO 100
         IP = 1
         IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.
  100    IF (.NOT. SELECT(K)) GO TO 960
         IF (WI(K) .NE. 0.0E0) S = S + 1
         IF (S .GT. MM) GO TO 1000
         IF (UK .GE. K) GO TO 200
C     .......... CHECK FOR POSSIBLE SPLITTING ..........
         DO 120 UK = K, N
            IF (UK .EQ. N) GO TO 140
            IF (A(UK+1,UK) .EQ. 0.0E0) GO TO 140
  120    CONTINUE
C     .......... COMPUTE INFINITY NORM OF LEADING UK BY UK
C                (HESSENBERG) MATRIX ..........
  140    NORM = 0.0E0
         MP = 1
C
         DO 180 I = 1, UK
            X = 0.0E0
C
            DO 160 J = MP, UK
  160       X = X + ABS(A(I,J))
C
            IF (X .GT. NORM) NORM = X
            MP = I
  180    CONTINUE
C     .......... EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION
C                AND CLOSE ROOTS ARE MODIFIED BY EPS3 ..........
         IF (NORM .EQ. 0.0E0) NORM = 1.0E0
         EPS3 = NORM
  190    EPS3 = 0.5E0*EPS3
         IF (NORM + EPS3 .GT. NORM) GO TO 190
         EPS3 = 2.0E0*EPS3
C     .......... GROWTO IS THE CRITERION FOR THE GROWTH ..........
         UKROOT = SQRT(REAL(UK))
         GROWTO = 0.1E0 / UKROOT
  200    RLAMBD = WR(K)
         ILAMBD = WI(K)
         IF (K .EQ. 1) GO TO 280
         KM1 = K - 1
         GO TO 240
C     .......... PERTURB EIGENVALUE IF IT IS CLOSE
C                TO ANY PREVIOUS EIGENVALUE ..........
  220    RLAMBD = RLAMBD + EPS3
C     .......... FOR I=K-1 STEP -1 UNTIL 1 DO -- ..........
  240    DO 260 II = 1, KM1
            I = K - II
            IF (SELECT(I) .AND. ABS(WR(I)-RLAMBD) .LT. EPS3 .AND.
     1         ABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220
  260    CONTINUE
C
         WR(K) = RLAMBD
C     .......... PERTURB CONJUGATE EIGENVALUE TO MATCH ..........
         IP1 = K + IP
         WR(IP1) = RLAMBD
C     .......... FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)
C                AND INITIAL REAL VECTOR ..........
  280    MP = 1
C
         DO 320 I = 1, UK
C
            DO 300 J = MP, UK
  300       RM1(J,I) = A(I,J)
C
            RM1(I,I) = RM1(I,I) - RLAMBD
            MP = I
            RV1(I) = EPS3
  320    CONTINUE
C
         ITS = 0
         IF (ILAMBD .NE. 0.0E0) GO TO 520
C     .......... REAL EIGENVALUE.
C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C                REPLACING ZERO PIVOTS BY EPS3 ..........
         IF (UK .EQ. 1) GO TO 420
C
         DO 400 I = 2, UK
            MP = I - 1
            IF (ABS(RM1(MP,I)) .LE. ABS(RM1(MP,MP))) GO TO 360
C
            DO 340 J = MP, UK
               Y = RM1(J,I)
               RM1(J,I) = RM1(J,MP)
               RM1(J,MP) = Y
  340       CONTINUE
C
  360       IF (RM1(MP,MP) .EQ. 0.0E0) RM1(MP,MP) = EPS3
            X = RM1(MP,I) / RM1(MP,MP)
            IF (X .EQ. 0.0E0) GO TO 400
C
            DO 380 J = I, UK
  380       RM1(J,I) = RM1(J,I) - X * RM1(J,MP)
C
  400    CONTINUE
C
  420    IF (RM1(UK,UK) .EQ. 0.0E0) RM1(UK,UK) = EPS3
C     .......... BACK SUBSTITUTION FOR REAL VECTOR
C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  440    DO 500 II = 1, UK
            I = UK + 1 - II
            Y = RV1(I)
            IF (I .EQ. UK) GO TO 480
            IP1 = I + 1
C
            DO 460 J = IP1, UK
  460       Y = Y - RM1(J,I) * RV1(J)
C
  480       RV1(I) = Y / RM1(I,I)
  500    CONTINUE
C
         GO TO 740
C     .......... COMPLEX EIGENVALUE.
C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,
C                REPLACING ZERO PIVOTS BY EPS3.  STORE IMAGINARY
C                PARTS IN UPPER TRIANGLE STARTING AT (1,3) ..........
  520    NS = N - S
         Z(1,S-1) = -ILAMBD
         Z(1,S) = 0.0E0
         IF (N .EQ. 2) GO TO 550
         RM1(1,3) = -ILAMBD
         Z(1,S-1) = 0.0E0
         IF (N .EQ. 3) GO TO 550
C
         DO 540 I = 4, N
  540    RM1(1,I) = 0.0E0
C
  550    DO 640 I = 2, UK
            MP = I - 1
            W = RM1(MP,I)
            IF (I .LT. N) T = RM1(MP,I+1)
            IF (I .EQ. N) T = Z(MP,S-1)
            X = RM1(MP,MP) * RM1(MP,MP) + T * T
            IF (W * W .LE. X) GO TO 580
            X = RM1(MP,MP) / W
            Y = T / W
            RM1(MP,MP) = W
            IF (I .LT. N) RM1(MP,I+1) = 0.0E0
            IF (I .EQ. N) Z(MP,S-1) = 0.0E0
C
            DO 560 J = I, UK
               W = RM1(J,I)
               RM1(J,I) = RM1(J,MP) - X * W
               RM1(J,MP) = W
               IF (J .LT. N1) GO TO 555
               L = J - NS
               Z(I,L) = Z(MP,L) - Y * W
               Z(MP,L) = 0.0E0
               GO TO 560
  555          RM1(I,J+2) = RM1(MP,J+2) - Y * W
               RM1(MP,J+2) = 0.0E0
  560       CONTINUE
C
            RM1(I,I) = RM1(I,I) - Y * ILAMBD
            IF (I .LT. N1) GO TO 570
            L = I - NS
            Z(MP,L) = -ILAMBD
            Z(I,L) = Z(I,L) + X * ILAMBD
            GO TO 640
  570       RM1(MP,I+2) = -ILAMBD
            RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD
            GO TO 640
  580       IF (X .NE. 0.0E0) GO TO 600
            RM1(MP,MP) = EPS3
            IF (I .LT. N) RM1(MP,I+1) = 0.0E0
            IF (I .EQ. N) Z(MP,S-1) = 0.0E0
            T = 0.0E0
            X = EPS3 * EPS3
  600       W = W / X
            X = RM1(MP,MP) * W
            Y = -T * W
C
            DO 620 J = I, UK
               IF (J .LT. N1) GO TO 610
               L = J - NS
               T = Z(MP,L)
               Z(I,L) = -X * T - Y * RM1(J,MP)
               GO TO 615
  610          T = RM1(MP,J+2)
               RM1(I,J+2) = -X * T - Y * RM1(J,MP)
  615          RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T
  620       CONTINUE
C
            IF (I .LT. N1) GO TO 630
            L = I - NS
            Z(I,L) = Z(I,L) - ILAMBD
            GO TO 640
  630       RM1(I,I+2) = RM1(I,I+2) - ILAMBD
  640    CONTINUE
C
         IF (UK .LT. N1) GO TO 650
         L = UK - NS
         T = Z(UK,L)
         GO TO 655
  650    T = RM1(UK,UK+2)
  655    IF (RM1(UK,UK) .EQ. 0.0E0 .AND. T .EQ. 0.0E0) RM1(UK,UK) = EPS3
C     .......... BACK SUBSTITUTION FOR COMPLEX VECTOR
C                FOR I=UK STEP -1 UNTIL 1 DO -- ..........
  660    DO 720 II = 1, UK
            I = UK + 1 - II
            X = RV1(I)
            Y = 0.0E0
            IF (I .EQ. UK) GO TO 700
            IP1 = I + 1
C
            DO 680 J = IP1, UK
               IF (J .LT. N1) GO TO 670
               L = J - NS
               T = Z(I,L)
               GO TO 675
  670          T = RM1(I,J+2)
  675          X = X - RM1(J,I) * RV1(J) + T * RV2(J)
               Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)
  680       CONTINUE
C
  700       IF (I .LT. N1) GO TO 710
            L = I - NS
            T = Z(I,L)
            GO TO 715
  710       T = RM1(I,I+2)
  715       CALL CDIV(X,Y,RM1(I,I),T,RV1(I),RV2(I))
  720    CONTINUE
C     .......... ACCEPTANCE TEST FOR REAL OR COMPLEX
C                EIGENVECTOR AND NORMALIZATION ..........
  740    ITS = ITS + 1
         NORM = 0.0E0
         NORMV = 0.0E0
C
         DO 780 I = 1, UK
            IF (ILAMBD .EQ. 0.0E0) X = ABS(RV1(I))
            IF (ILAMBD .NE. 0.0E0) X = PYTHAG(RV1(I),RV2(I))
            IF (NORMV .GE. X) GO TO 760
            NORMV = X
            J = I
  760       NORM = NORM + X
  780    CONTINUE
C
         IF (NORM .LT. GROWTO) GO TO 840
C     .......... ACCEPT VECTOR ..........
         X = RV1(J)
         IF (ILAMBD .EQ. 0.0E0) X = 1.0E0 / X
         IF (ILAMBD .NE. 0.0E0) Y = RV2(J)
C
         DO 820 I = 1, UK
            IF (ILAMBD .NE. 0.0E0) GO TO 800
            Z(I,S) = RV1(I) * X
            GO TO 820
  800       CALL CDIV(RV1(I),RV2(I),X,Y,Z(I,S-1),Z(I,S))
  820    CONTINUE
C
         IF (UK .EQ. N) GO TO 940
         J = UK + 1
         GO TO 900
C     .......... IN-LINE PROCEDURE FOR CHOOSING
C                A NEW STARTING VECTOR ..........
  840    IF (ITS .GE. UK) GO TO 880
         X = UKROOT
         Y = EPS3 / (X + 1.0E0)
         RV1(1) = EPS3
C
         DO 860 I = 2, UK
  860    RV1(I) = Y
C
         J = UK - ITS + 1
         RV1(J) = RV1(J) - EPS3 * X
         IF (ILAMBD .EQ. 0.0E0) GO TO 440
         GO TO 660
C     .......... SET ERROR -- UNACCEPTED EIGENVECTOR ..........
  880    J = 1
         IERR = -K
C     .......... SET REMAINING VECTOR COMPONENTS TO ZERO ..........
  900    DO 920 I = J, N
            Z(I,S) = 0.0E0
            IF (ILAMBD .NE. 0.0E0) Z(I,S-1) = 0.0E0
  920    CONTINUE
C
  940    S = S + 1
  960    IF (IP .EQ. (-1)) IP = 0
         IF (IP .EQ. 1) IP = -1
  980 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- UNDERESTIMATE OF EIGENVECTOR
C                SPACE REQUIRED ..........
 1000 IF (IERR .NE. 0) IERR = IERR - N
      IF (IERR .EQ. 0) IERR = -(2 * N + 1)
 1001 M = S - 1 - ABS(IP)
      RETURN
      END


c { dg-do run }
c  intrinsic-unix-bessel.f
c
c Test Bessel function intrinsics.
c These functions are only available if provided by system
c
c     David Billinghurst <David.Billinghurst@riotinto.com>
c
      real x, a
      double precision dx, da
      integer i
      integer(kind=2) j
      integer(kind=1) k
      integer(kind=8) m
      logical fail
      common /flags/ fail
      fail = .false.

      x = 2.0
      dx = x
      i = 2
      j = i
      k = i
      m = i
c     BESJ0  - Bessel function of first kind of order zero
      a = 0.22389077
      da = a
      call c_r(BESJ0(x),a,'BESJ0(real)')
      call c_d(BESJ0(dx),da,'BESJ0(double)')
      call c_d(DBESJ0(dx),da,'DBESJ0(double)')

c     BESJ1  - Bessel function of first kind of order one
      a = 0.57672480
      da = a
      call c_r(BESJ1(x),a,'BESJ1(real)')
      call c_d(BESJ1(dx),da,'BESJ1(double)')
      call c_d(DBESJ1(dx),da,'DBESJ1(double)')

c     BESJN  - Bessel function of first kind of order N
      a = 0.3528340
      da = a
      call c_r(BESJN(i,x),a,'BESJN(integer,real)')
      call c_r(BESJN(j,x),a,'BESJN(integer(2),real)')
      call c_r(BESJN(k,x),a,'BESJN(integer(1),real)')
      call c_d(BESJN(i,dx),da,'BESJN(integer,double)')
      call c_d(BESJN(j,dx),da,'BESJN(integer(2),double)')
      call c_d(BESJN(k,dx),da,'BESJN(integer(1),double)')
      call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)')
      call c_d(DBESJN(j,dx),da,'DBESJN(integer(2),double)')
      call c_d(DBESJN(k,dx),da,'DBESJN(integer(1),double)')

c     BESY0  - Bessel function of second kind of order zero
      a = 0.51037567
      da = a
      call c_r(BESY0(x),a,'BESY0(real)')
      call c_d(BESY0(dx),da,'BESY0(double)')
      call c_d(DBESY0(dx),da,'DBESY0(double)')

c     BESY1  - Bessel function of second kind of order one
      a = 0.-0.1070324
      da = a
      call c_r(BESY1(x),a,'BESY1(real)')
      call c_d(BESY1(dx),da,'BESY1(double)')
      call c_d(DBESY1(dx),da,'DBESY1(double)')

c     BESYN  - Bessel function of second kind of order N
      a = -0.6174081
      da = a
      call c_r(BESYN(i,x),a,'BESYN(integer,real)')
      call c_r(BESYN(j,x),a,'BESYN(integer(2),real)')
      call c_r(BESYN(k,x),a,'BESYN(integer(1),real)')
      call c_d(BESYN(i,dx),da,'BESYN(integer,double)')
      call c_d(BESYN(j,dx),da,'BESYN(integer(2),double)')
      call c_d(BESYN(k,dx),da,'BESYN(integer(1),double)')
      call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)')
      call c_d(DBESYN(j,dx),da,'DBESYN(integer(2),double)')
      call c_d(DBESYN(k,dx),da,'DBESYN(integer(1),double)')

      if ( fail ) STOP 1
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_r(a,b,label)
c     Check if REAL a equals b, and fail otherwise
      real a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0e-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end

      subroutine c_d(a,b,label)
c     Check if DOUBLE PRECISION a equals b, and fail otherwise
      double precision a, b
      character*(*) label
      if ( abs(a-b) .gt. 1.0d-5 ) then
         call failure(label)
         write(6,*) 'Got ',a,' expected ', b
      end if
      end


    Program dspevd_example

!     DSPEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_blas_damax_val, &
        nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dspevd
      Use lapack_precision, Only: dp !
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: r
      Integer :: i, ifail, info, j, k, ldz, liwork, lwork, n
      Character (1) :: job, uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ap(:), w(:), work(:), z(:, :)
      Integer, Allocatable :: iwork(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSPEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldz = n
      liwork = 5*n + 3
      lwork = n*n + 6*n + 1
      Allocate (ap(n*(n+1)/2), w(n), work(lwork), z(ldz,n), iwork(liwork))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Read (nin, *)((ap(i+j*(j-1)/2),j=i,n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ap(i+(2*n-j)*(j-1)/2),j=1,i), i=1, n)
      End If

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of A
      Call dspevd(job, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, &
        info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors: largest element positive
        Do i = 1, n
          Call nagf_blas_damax_val(n, z(1,i), 1, k, r)
          If (z(k,i)<zero) Then
            z(1:n, i) = -z(1:n, i)
          End If
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, (8F8.4))
    End Program


subroutine collision()
    use commondata
    implicit none
    integer :: i, j, k
    integer :: alpha
    !---------------------------
    real(8) :: s(0:18)
    real(8) :: m(0:18)
    real(8) :: m_post(0:18)
    real(8) :: meq(0:18)
    !---------------------------
    ! real(8) :: us2, un, feq
    !---------------------------

    do k = 1, nz
        do j = 1, ny
            do i = 1, nx
    ! loop body, re-indented for readability

    m(0) = f(0,i,j,k) &
        + f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)
    m(1) = -30.0d0 * f(0,i,j,k) &
        - 11.0d0 * (f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + 8.0d0 * (f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k)) &
        + 8.0d0 * (f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(2) = 12.0d0 * f(0,i,j,k) &
        - 4.0d0 * (f(1,i,j,k) + f(2,i,j,k) + f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)
    m(3) = f(1,i,j,k) - f(2,i,j,k) &
        + f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) + f(11,i,j,k) - f(12,i,j,k) &
        + f(13,i,j,k) - f(14,i,j,k)
    m(4) = -4.0d0 * (f(1,i,j,k) - f(2,i,j,k)) &
        + f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) + f(11,i,j,k) - f(12,i,j,k) &
        + f(13,i,j,k) - f(14,i,j,k)
    m(5) = f(3,i,j,k) - f(4,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) - f(9,i,j,k) - f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(6) = -4.0d0 * (f(3,i,j,k) - f(4,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) - f(9,i,j,k) - f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(7) = f(5,i,j,k) - f(6,i,j,k) &
        + f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) - f(17,i,j,k) - f(18,i,j,k)
    m(8) = -4.0d0 * (f(5,i,j,k) - f(6,i,j,k)) &
        + f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) + f(15,i,j,k) + f(16,i,j,k) - f(17,i,j,k) - f(18,i,j,k)
    m(9) = 2.0d0 * (f(1,i,j,k) + f(2,i,j,k)) - f(3,i,j,k) - f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) - 2.0 * (f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(10) = -4.0d0 * (f(1,i,j,k) + f(2,i,j,k)) + 2.0d0 * (f(3,i,j,k) + f(4,i,j,k) + f(5,i,j,k) + f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) + f(11,i,j,k) + f(12,i,j,k) &
        + f(13,i,j,k) + f(14,i,j,k) - 2.0 * (f(15,i,j,k) + f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k))
    m(11) = f(3,i,j,k) + f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) - f(11,i,j,k) - f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k)
    m(12) = -2.0d0 * (f(3,i,j,k) + f(4,i,j,k) - f(5,i,j,k) - f(6,i,j,k)) &
        + f(7,i,j,k) + f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) - f(11,i,j,k) - f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k)
    m(13) = f(7,i,j,k) - f(8,i,j,k) - f(9,i,j,k) + f(10,i,j,k)
    m(14) = f(15,i,j,k) - f(16,i,j,k) - f(17,i,j,k) + f(18,i,j,k)
    m(15) = f(11,i,j,k) - f(12,i,j,k) - f(13,i,j,k) + f(14,i,j,k)
    m(16) = f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) - f(10,i,j,k) - f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) + f(14,i,j,k)
    m(17) = -f(7,i,j,k) - f(8,i,j,k) + f(9,i,j,k) + f(10,i,j,k) &
        + f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) - f(18,i,j,k)
    m(18) = f(11,i,j,k) + f(12,i,j,k) &
        - f(13,i,j,k) - f(14,i,j,k) - f(15,i,j,k) - f(16,i,j,k) + f(17,i,j,k) + f(18,i,j,k)

        meq(0) = rho(i,j,k)
        meq(1) = rho(i,j,k) * (-11.0d0 + 19.0d0 * (u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)))
        meq(2) = rho(i,j,k) * (3.0d0 - 11.0d0/2.0d0 * (u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)))
        meq(3) = rho(i,j,k) * u(i,j,k)
        meq(4) = -2.0d0/3.0d0 * rho(i,j,k) * u(i,j,k)
        meq(5) = rho(i,j,k) * v(i,j,k)
        meq(6) = -2.0d0/3.0d0 * rho(i,j,k) * v(i,j,k)
        meq(7) = rho(i,j,k) * w(i,j,k)
        meq(8) = -2.0d0/3.0d0 * rho(i,j,k) * w(i,j,k)
        meq(9) = rho(i,j,k) * (2.0d0 * u(i,j,k)*u(i,j,k) - v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(10) = -1.0d0/2.0d0 * rho(i,j,k) * (2.0d0 * u(i,j,k)*u(i,j,k) - v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(11) = rho(i,j,k) * (v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(12) = -1.0d0/2.0d0 * (v(i,j,k)*v(i,j,k) - w(i,j,k)*w(i,j,k))
        meq(13) = rho(i,j,k) * u(i,j,k) * v(i,j,k)
        meq(14) = rho(i,j,k) * v(i,j,k) * w(i,j,k)
        meq(15) = rho(i,j,k) * u(i,j,k) * w(i,j,k)
        meq(16) = 0.0d0
        meq(17) = 0.0d0
        meq(18) = 0.0d0

        s(0) = 0.0d0    !! s_{\rho}
        s(1) = Snu      !! s_{e}
        s(2) = Snu      !! s_{epsilon}
        s(3) = 0.0d0    !! s_{j}
        s(4) = Sq       !! s_{q}
        s(5) = 0.0d0    !! s_{j}
        s(6) = Sq       !! s_{q}
        s(7) = 0.0d0    !! s_{j}
        s(8) = Sq       !! s_{q}
        s(9) = Snu      !! s_{\nu}
        s(10) = Snu     !! s_{\pi}
        s(11) = Snu     !! s_{\nu}
        s(12) = Snu     !! s_{\pi}
        s(13) = Snu     !! s_{nu}
        s(14) = Snu     !! s_{nu}
        s(15) = Snu     !! s_{nu}
        s(16) = Sq      !! s_{m}
        s(17) = Sq      !! s_{m}
        s(18) = Sq      !! s_{m}

        do alpha=0,18
            m_post(alpha) = m(alpha)-s(alpha)*(m(alpha)-meq(alpha))
        enddo

    f_post(0,i,j,k) = m_post(0)/19.0d0 - 5.0d0/399.0d0*m_post(1) + m_post(2)/21.0d0

    ! ------------
    f_post(1,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(3)/10.0d0 &
        - m_post(4)/10.0d0 + m_post(9)/18.0d0 - m_post(10)/18.0d0

    f_post(2,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(3)/10.0d0 &
        + m_post(4)/10.0d0 + m_post(9)/18.0d0 - m_post(10)/18.0d0

    ! ------------
    f_post(3,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(5)/10.0d0 &
        - m_post(6)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 + m_post(11)/12.0d0 - m_post(12)/12.0d0

    f_post(4,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(5)/10.0d0 &
        + m_post(6)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 + m_post(11)/12.0d0 - m_post(12)/12.0d0

    f_post(5,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 + m_post(7)/10.0d0 &
        - m_post(8)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 - m_post(11)/12.0d0 + m_post(12)/12.0d0

    f_post(6,i,j,k) = m_post(0)/19.0d0 - 11.0d0/2394.0d0*m_post(1) - m_post(2)/63.0d0 - m_post(7)/10.0d0 &
        + m_post(8)/10.0d0 - m_post(9)/36.0d0 + m_post(10)/36.0d0 - m_post(11)/12.0d0 + m_post(12)/12.0d0

    ! ------------
    f_post(7,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 + m_post(5)/10.0d0 + m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 + m_post(13)/4.0d0 + m_post(16)/8.0d0 - m_post(17)/8.0d0

    f_post(8,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 + m_post(5)/10.0d0 + m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 - m_post(13)/4.0d0 - m_post(16)/8.0d0 - m_post(17)/8.0d0

    f_post(9,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 - m_post(5)/10.0d0 - m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 - m_post(13)/4.0d0 + m_post(16)/8.0d0 + m_post(17)/8.0d0

    f_post(10,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 - m_post(5)/10.0d0 - m_post(6)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        + m_post(11)/12.0d0 + m_post(12)/24.0d0 + m_post(13)/4.0d0 - m_post(16)/8.0d0 + m_post(17)/8.0d0

    ! -----------
    f_post(11,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 + m_post(15)/4.0d0 - m_post(16)/8.0d0 + m_post(18)/8.0d0

    f_post(12,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 - m_post(15)/4.0d0 + m_post(16)/8.0d0 + m_post(18)/8.0d0

    f_post(13,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(3)/10.0d0 &
        + m_post(4)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 - m_post(15)/4.0d0 - m_post(16)/8.0d0 - m_post(18)/8.0d0

    f_post(14,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(3)/10.0d0 &
        - m_post(4)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 + m_post(9)/36.0d0 + m_post(10)/72.0d0 &
        - m_post(11)/12.0d0 - m_post(12)/24.0d0 + m_post(15)/4.0d0 + m_post(16)/8.0d0 - m_post(18)/8.0d0

    ! -----------
    f_post(15,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(5)/10.0d0 &
        + m_post(6)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        + m_post(14)/4.0d0 + m_post(17)/8.0d0 - m_post(18)/8.0d0

    f_post(16,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(5)/10.0d0 &
        - m_post(6)/40.0d0 + m_post(7)/10.0d0 + m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        - m_post(14)/4.0d0 - m_post(17)/8.0d0 - m_post(18)/8.0d0

    f_post(17,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 + m_post(5)/10.0d0 &
        + m_post(6)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        - m_post(14)/4.0d0 + m_post(17)/8.0d0 + m_post(18)/8.0d0

    f_post(18,i,j,k) = m_post(0)/19.0d0 + 4.0d0/1197.0d0*m_post(1) + m_post(2)/252.0d0 - m_post(5)/10.0d0 &
        - m_post(6)/40.0d0 - m_post(7)/10.0d0 - m_post(8)/40.0d0 - m_post(9)/18.0d0 - m_post(10)/36.0d0 &
        + m_post(14)/4.0d0 - m_post(17)/8.0d0 + m_post(18)/8.0d0

                ! us2 = u(i,j,k)*u(i,j,k) + v(i,j,k)*v(i,j,k) + w(i,j,k)*w(i,j,k)
                ! do alpha = 0, 18
                !     un = u(i,j,k)*ex(alpha) + v(i,j,k)*ey(alpha) + w(i,j,k)*ez(alpha)
                !     feq = rho(i,j,k) * omega(alpha) * (1.0d0 + 3.0d0*un + 4.5d0*un*un - 1.5d0*us2)

                !     f_post(alpha,i,j,k) = f(alpha,i,j,k) - Snu*(f(alpha,i,j,k) - feq)
                ! enddo

            enddo
        enddo
    enddo

    return
end subroutine collision


program i
  real ::b=10.0 * (4+3.0)
  real  ::c=4.0 / (1+2.22)
  real ::a
  a = 3.0 * (b * c)  + (5**1)
  b = 20.0
end program i


      SUBROUTINE slSVD (M, N, MP, NP, A, W, V, WORK, JSTAT)
*+
*     - - - -
*      S V D
*     - - - -
*
*  Singular value decomposition  (double precision)
*
*  This routine expresses a given matrix A as the product of
*  three matrices U, W, V:
*
*     A = U x W x VT
*
*  Where:
*
*     A   is any M (rows) x N (columns) matrix, where M.GE.N
*     U   is an M x N column-orthogonal matrix
*     W   is an N x N diagonal matrix with W(I,I).GE.0
*     VT  is the transpose of an N x N orthogonal matrix
*
*     Note that M and N, above, are the LOGICAL dimensions of the
*     matrices and vectors concerned, which can be located in
*     arrays of larger PHYSICAL dimensions, given by MP and NP.
*
*  Given:
*     M,N    i         numbers of rows and columns in matrix A
*     MP,NP  i         physical dimensions of array containing matrix A
*     A      d(MP,NP)  array containing MxN matrix A
*
*  Returned:
*     A      d(MP,NP)  array containing MxN column-orthogonal matrix U
*     W      d(N)      NxN diagonal matrix W (diagonal elements only)
*     V      d(NP,NP)  array containing NxN orthogonal matrix V
*     WORK   d(N)      workspace
*     JSTAT  i         0 = OK, -1 = A wrong shape, >0 = index of W
*                      for which convergence failed.  See note 2, below.
*
*   Notes:
*
*   1)  V contains matrix V, not the transpose of matrix V.
*
*   2)  If the status JSTAT is greater than zero, this need not
*       necessarily be treated as a failure.  It means that, due to
*       chance properties of the matrix A, the QR transformation
*       phase of the routine did not fully converge in a predefined
*       number of iterations, something that very seldom occurs.
*       When this condition does arise, it is possible that the
*       elements of the diagonal matrix W have not been correctly
*       found.  However, in practice the results are likely to
*       be trustworthy.  Applications should report the condition
*       as a warning, but then proceed normally.
*
*  References:
*     The algorithm is an adaptation of the routine SVD in the EISPACK
*     library (Garbow et al 1977, EISPACK Guide Extension, Springer
*     Verlag), which is a FORTRAN 66 implementation of the Algol
*     routine SVD of Wilkinson & Reinsch 1971 (Handbook for Automatic
*     Computation, vol 2, ed Bauer et al, Springer Verlag).  These
*     references give full details of the algorithm used here.  A good
*     account of the use of SVD in least squares problems is given in
*     Numerical Recipes (Press et al 1986, Cambridge University Press),
*     which includes another variant of the EISPACK code.
*
*  Last revision:   8 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER M,N,MP,NP
      DOUBLE PRECISION A(MP,NP),W(N),V(NP,NP),WORK(N)
      INTEGER JSTAT

*  Maximum number of iterations in QR phase
      INTEGER ITMAX
      PARAMETER (ITMAX=30)

      INTEGER L,L1,I,K,J,K1,ITS,I1
      LOGICAL CANCEL
      DOUBLE PRECISION G,SCALE,AN,S,X,F,H,C,Y,Z

*  Variable initializations to avoid compiler warnings.
      L = 0
      L1 = 0

*  Check that the matrix is the right shape
      IF (M.LT.N) THEN

*     No:  error status
         JSTAT = -1

      ELSE

*     Yes:  preset the status to OK
         JSTAT = 0

*
*     Householder reduction to bidiagonal form
*     ----------------------------------------

         G = 0D0
         SCALE = 0D0
         AN = 0D0
         DO I=1,N
            L = I+1
            WORK(I) = SCALE*G
            G = 0D0
            S = 0D0
            SCALE = 0D0
            IF (I.LE.M) THEN
               DO K=I,M
                  SCALE = SCALE+ABS(A(K,I))
               END DO
               IF (SCALE.NE.0D0) THEN
                  DO K=I,M
                     X = A(K,I)/SCALE
                     A(K,I) = X
                     S = S+X*X
                  END DO
                  F = A(I,I)
                  G = -SIGN(SQRT(S),F)
                  H = F*G-S
                  A(I,I) = F-G
                  IF (I.NE.N) THEN
                     DO J=L,N
                        S = 0D0
                        DO K=I,M
                           S = S+A(K,I)*A(K,J)
                        END DO
                        F = S/H
                        DO K=I,M
                           A(K,J) = A(K,J)+F*A(K,I)
                        END DO
                     END DO
                  END IF
                  DO K=I,M
                     A(K,I) = SCALE*A(K,I)
                  END DO
               END IF
            END IF
            W(I) = SCALE*G
            G = 0D0
            S = 0D0
            SCALE = 0D0
            IF (I.LE.M .AND. I.NE.N) THEN
               DO K=L,N
                  SCALE = SCALE+ABS(A(I,K))
               END DO
               IF (SCALE.NE.0D0) THEN
                  DO K=L,N
                     X = A(I,K)/SCALE
                     A(I,K) = X
                     S = S+X*X
                  END DO
                  F = A(I,L)
                  G = -SIGN(SQRT(S),F)
                  H = F*G-S
                  A(I,L) = F-G
                  DO K=L,N
                     WORK(K) = A(I,K)/H
                  END DO
                  IF (I.NE.M) THEN
                     DO J=L,M
                        S = 0D0
                        DO K=L,N
                           S = S+A(J,K)*A(I,K)
                        END DO
                        DO K=L,N
                           A(J,K) = A(J,K)+S*WORK(K)
                        END DO
                     END DO
                  END IF
                  DO K=L,N
                     A(I,K) = SCALE*A(I,K)
                  END DO
               END IF
            END IF

*        Overestimate of largest column norm for convergence test
            AN = MAX(AN,ABS(W(I))+ABS(WORK(I)))

         END DO

*
*     Accumulation of right-hand transformations
*     ------------------------------------------

         DO I=N,1,-1
            IF (I.NE.N) THEN
               IF (G.NE.0D0) THEN
                  DO J=L,N
                     V(J,I) = (A(I,J)/A(I,L))/G
                  END DO
                  DO J=L,N
                     S = 0D0
                     DO K=L,N
                        S = S+A(I,K)*V(K,J)
                     END DO
                     DO K=L,N
                        V(K,J) = V(K,J)+S*V(K,I)
                     END DO
                  END DO
               END IF
               DO J=L,N
                  V(I,J) = 0D0
                  V(J,I) = 0D0
               END DO
            END IF
            V(I,I) = 1D0
            G = WORK(I)
            L = I
         END DO

*
*     Accumulation of left-hand transformations
*     -----------------------------------------

         DO I=N,1,-1
            L = I+1
            G = W(I)
            IF (I.NE.N) THEN
               DO J=L,N
                  A(I,J) = 0D0
               END DO
            END IF
            IF (G.NE.0D0) THEN
               IF (I.NE.N) THEN
                  DO J=L,N
                     S = 0D0
                     DO K=L,M
                        S = S+A(K,I)*A(K,J)
                     END DO
                     F = (S/A(I,I))/G
                     DO K=I,M
                        A(K,J) = A(K,J)+F*A(K,I)
                     END DO
                  END DO
               END IF
               DO J=I,M
                  A(J,I) = A(J,I)/G
               END DO
            ELSE
               DO J=I,M
                  A(J,I) = 0D0
               END DO
            END IF
            A(I,I) = A(I,I)+1D0
         END DO

*
*     Diagonalisation of the bidiagonal form
*     --------------------------------------

         DO K=N,1,-1
            K1 = K-1

*        Iterate until converged
            ITS = 0
            DO WHILE (ITS.LT.ITMAX)
               ITS = ITS+1

*           Test for splitting into submatrices
               CANCEL = .TRUE.
               DO L=K,1,-1
                  L1 = L-1
                  IF (AN+ABS(WORK(L)).EQ.AN) THEN
                     CANCEL = .FALSE.
                     GO TO 10
                  END IF
*              (Following never attempted for L=1 because WORK(1) is zero)
                  IF (AN+ABS(W(L1)).EQ.AN) GO TO 10
               END DO
 10            CONTINUE

*           Cancellation of WORK(L) if L>1
               IF (CANCEL) THEN
                  C = 0D0
                  S = 1D0
                  DO I=L,K
                     F = S*WORK(I)
                     IF (AN+ABS(F).EQ.AN) GO TO 20
                     G = W(I)
                     H = SQRT(F*F+G*G)
                     W(I) = H
                     C = G/H
                     S = -F/H
                     DO J=1,M
                        Y = A(J,L1)
                        Z = A(J,I)
                        A(J,L1) = Y*C+Z*S
                        A(J,I) = -Y*S+Z*C
                     END DO
                  END DO
 20               CONTINUE
               END IF

*           Converged?
               Z = W(K)
               IF (L.EQ.K) THEN

*              Yes:  stop iterating
                  ITS = ITMAX

*              Ensure singular values non-negative
                  IF (Z.LT.0D0) THEN
                     W(K) = -Z
                     DO J=1,N
                        V(J,K) = -V(J,K)
                     END DO
                  END IF
               ELSE

*              Not converged yet:  set status if iteration limit reached
                  IF (ITS.EQ.ITMAX) JSTAT = K

*              Shift from bottom 2x2 minor
                  X = W(L)
                  Y = W(K1)
                  G = WORK(K1)
                  H = WORK(K)
                  F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2D0*H*Y)
                  IF (ABS(F).LE.1D15) THEN
                     G = SQRT(F*F+1D0)
                  ELSE
                     G = ABS(F)
                  END IF
                  F = ((X-Z)*(X+Z)+H*(Y/(F+SIGN(G,F))-H))/X

*              Next QR transformation
                  C = 1D0
                  S = 1D0
                  DO I1=L,K1
                     I = I1+1
                     G = WORK(I)
                     Y = W(I)
                     H = S*G
                     G = C*G
                     Z = SQRT(F*F+H*H)
                     WORK(I1) = Z
                     IF (Z.NE.0D0) THEN
                        C = F/Z
                        S = H/Z
                     ELSE
                        C = 1D0
                        S = 0D0
                     END IF
                     F = X*C+G*S
                     G = -X*S+G*C
                     H = Y*S
                     Y = Y*C
                     DO J=1,N
                        X = V(J,I1)
                        Z = V(J,I)
                        V(J,I1) = X*C+Z*S
                        V(J,I) = -X*S+Z*C
                     END DO
                     Z = SQRT(F*F+H*H)
                     W(I1) = Z
                     IF (Z.NE.0D0) THEN
                        C = F/Z
                        S = H/Z
                     END IF
                     F = C*G+S*Y
                     X = -S*G+C*Y
                     DO J=1,M
                        Y = A(J,I1)
                        Z = A(J,I)
                        A(J,I1) = Y*C+Z*S
                        A(J,I) = -Y*S+Z*C
                     END DO
                  END DO
                  WORK(L) = 0D0
                  WORK(K) = F
                  W(K) = X
               END IF
            END DO
         END DO
      END IF

      END


!KORTEWEG-DEVRIES

!L'equazione risolta è quella di korteweg-deVries al caso normalizzato su fondovariabile
!in questa simulazione il fondo è con una funzione di -arctangente(scalino)
!Calcolo massimo,velocità

program fondovariabile
integer i,icicli,isalva,i0,i1,i2,imax
real*8,allocatable, dimension (:) :: U,Unew,F,x,H,Xnew,vel
real*8,allocatable, dimension (:) :: xx_max,uu_max,vv_max,aa_max
character*30 filename
character nom1, nom2, nom0
real*8 :: pigreco,alpha,beta,Umax,xmax
!-------------------------------------variabili
common /parametri/ deltax,h0

pigreco=4.0*atan(1.0)

!------------------------Apro il file da cui prendo i dati

open(7,file='Dati.txt')
read(7,*) N
read(7,*) xmin
read(7,*) xmax
read(7,*) deltat
read(7,*) Ncicli
read(7,*) Nsalva
read(7,*) h0
read(7,*) c
read(7,*) a

close(1)
!---------------------------Ho preso i dati da file

allocate(U(0:N-1),Unew(0:N-1),x(0:N-1),F(0:N-1),H(0:N-1),Xnew(1:Ncicli),vel(1:Ncicli))
 deltax=(xmax-xmin)/N

 write(*,*) 'Valore di N pari a :',N
 write(*,*) 'Deltax uguale a :',deltax

 !++++++++++++++++++++++++++++++++++++++++++++++++++++++ Condizioni iniziali

 !**********************************************************
 !----------------------------Alpha e Beta devono essere << 1
 alpha=a/h0
 beta=((h0/c)**2)/6
 !**********************************************************

 Umax=0

 write(*,*) 'Inizializzazione'

 do i=0, N-1
 x(i)=xmin+i*deltax
 !write(*,*),x(i)

 U(i)=(dcosh(x(i))**(-2)) !controllare formula Whitham
 !print*,U(i)
 H(i)=0.2*datan(2*(x(i)-2.5))!****************************************tipo di fondo

end do
 !---------------------------------------------------------------- Fine condizioni Iniziali

 write(*,*) 'Variabili Iniazializzate!'

 !...Apertura file salvataggio posizione picco
 open(20,file='pos_val_max.txt')

 !INIZIO CICLO
 !**********************************************************************
 do icicli=1, Ncicli
 !***********************************************************************

 !------------------------------------------------------start salva
 do isalva=0, Nsalva-1

 !+++++++++++++++++++++++++++++++++++++++++++++ inizio calcolo effettivo

  call calcolaeffe(U,F,N,H,alpha,beta)

   do i=0, N-1

      Unew(i)=U(i)+0.5*deltat*F(i)

   end do

  call calcolaeffe(Unew,F,N,H,alpha,beta)

   do i=0, N-1

     U(i)=U(i)+deltat*F(i)
   end do

   Umax=U(0)
   do i=1,N-1
      if (U(i).gt.Umax) then
       Umax=U(i)
       imax=i
     end if

  end do

   x_max = x(imax)+.25*deltax*(U(imax+1)-U(imax-1))/(U(imax)-.5*(U(imax+1)+U(imax-1)))
   tempo=deltat*(isalva+(icicli-1)*Nsalva)
   write(20,*) tempo, x_max, Umax

  !+++++++++++++++++++++++++++++++++++++++++++++fine calcolo effettivo

 end do
 !-------------------------------------------------------------------------------end salva
 write(*,*)'Il valore massimo di U è...................', Umax

 write(*,*) 'Ciclo numero',icicli

 !definiamo il nome dei file su cui scrivere, si utilizza il seguente metodo

 i0=  icicli/100
 i1=  (icicli-i0*100)/10
 i2=  icicli-i0*100-i1*10

 nom0=char(i0+ichar ('0'))
 nom1=char(i1+ichar ('0'))
 nom2=char(i2+ichar ('0'))

         filename='kdvnormform'//nom0//nom1//nom2//'.txt'

 write(*,*)'Inizio scrittura su File', filename
 write(*,*) x(icicli),'/', U(N/2), F(N/2)

 open(5,file=filename,form='formatted')
 do i=0, N-1
 write(5,300) x(i),U(i)
 end do
 close(5)

 write(*,*) 'Fine scrittura su File', filename

 !******************************************************************************
 end do
 !*******************************************************************************
 !FINE CICLO

 300 format(2e16.7)

 close(20)

 !---------------------------------------calcolo la velocità dell'onde onde

 deallocate(U,Unew,x,F,H,Xnew)

!...Aggiunta calcolo velocità picco

open(20,file='pos_val_max.txt')
allocate(xx_max(1:Ncicli*Nsalva),uu_max(1:Ncicli*Nsalva),vv_max(1:Ncicli*Nsalva),aa_max(1:Ncicli*Nsalva))
do i=1,Ncicli*Nsalva
read(20,*) tempo, xx_max(i), uu_max(i)
end do
close(20)
vv_max(1)=(xx_max(2)-xx_max(1))/deltat

do i=2,Ncicli*Nsalva-1
vv_max(i)=(xx_max(i+1)-xx_max(i-1))/(2*deltat)
aa_max(i)=(xx_max(i+1)-2*xx_max(i)+xx_max(i-1))/(deltat**2)
end do

vv_max(Ncicli*Nsalva)=(xx_max(Ncicli*Nsalva)-xx_max(Ncicli*Nsalva-1))/deltat

open(20,file='pos_val_max_vel_acc.txt')
do i=1,Ncicli*Nsalva
write(20,*) i*deltat, xx_max(i), uu_max(i), vv_max(i),aa_max(i)
end do
close(20)

deallocate(uu_max,vv_max,xx_max,aa_max)

end program fondovariabile

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ SUBROUTINE

subroutine calcolaeffe (U,F,N,H,alpha,beta)
real*8, dimension(0:N-1) :: U,F,GG,H
integer :: i
real*8 :: beta,alpha

common /parametri/ deltax,h0

do i=0,N-1
GG(i) = U(i)*(1.0+0.75*U(i)*alpha)
end do

do i=2, N-2

F(i)=-(GG(i+1)-GG(i-1))/(2*deltax)&
                - beta*(U(i+2)-2*U(i+1)+2*U(i-1)-U(i+2))/(2*deltax**3)&
                 + 0.25*U(i)*(H(i+1)-H(i-1))/deltax

 end do

 H(N-1)=H(0)

 F(N-1)=-(GG(0)-GG(N-2))/(2*deltax)&
                  - beta*(U(1)-2*U(0)+2*U(N-2)-U(N-3))/(2*deltax**3)&
                           +0.25*U(N-1)*(H(0)-H(N-2))/deltax

 F(N-2)=-(GG(N-1)-GG(N-3))/(2*deltax)&
                  -beta*(U(0)-2*U(N-1)+2*U(N-3)-U(N-4))/(2*deltax**3)&
                           +0.25*U(N-2)*(H(N-1)-H(N-3))/deltax

 F(0)=-(GG(1)-GG(N-1))/(2*deltax)&
            - beta*((U(2)-2*U(1)+2*U(N-1)-U(N-2))/(2*deltax**3))&
                           +0.25*U(0)*(H(1)-H(N-1))/deltax

 F(1)=-(GG(2)-GG(0))/(2*deltax)&
             - beta*(U(3)-2*U(2)+2*U(0)-U(N-1))/(2*deltax**3)&
                           +0.25*U(1)*(H(2)-H(0))/deltax

end subroutine calcolaeffe


PROGRAM HomogeneousSphere1D

  USE KindModule, ONLY: &
    DP, Pi
  USE ProgramInitializationModule, ONLY: &
    InitializeProgram, &
    FinalizeProgram
  USE GravitySolutionModule, ONLY: &
    SolveGravity
  USE InputOutputModule, ONLY: &
    WriteFields1D
  USE GravityProblemsInitializationModule, ONLY: &
    InitializeHomogeneousSphere

  IMPLICIT NONE

  CALL InitializeProgram &
         ( ProgramName_Option &
             = 'HomogeneousSphere1D', &
           nX_Option &
             = [ 32, 1, 1 ], &
           swX_Option &
             = [ 1, 0, 0 ], &
           bcX_Option &
             = [ 3, 0, 0 ], &
           xL_Option &
             = [ 0.0_DP, 0.0_DP, 0.0_DP ], &
           xR_Option &
             = [ 2.0_DP, Pi,     4.0_DP ], &
           nNodes_Option &
             = 3, &
           CoordinateSystem_Option &
             = 'SPHERICAL', &
           GravitySolver_Option &
             = 'Newtonian_Poseidon' )

  CALL InitializeHomogeneousSphere &
         ( SphereRadius_Option = 1.0_DP )

  CALL SolveGravity

  CALL WriteFields1D &
         ( Time = 0.0_DP, WriteGeometryFields_Option = .TRUE. )

  CALL FinalizeProgram

END PROGRAM HomogeneousSphere1D


!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves Gierer Meinhardt equation in 3 dimensions
	! u_t + a(u_x + u_y + u_z) = d_1(u_{xx}+u_{yy}+u_{zz}) + p u^2/v - q_1 u + w_1
	! v_t + a(v_x + v_y + v_z) = d_2(v_{xx}+v_{yy}+v_{zz}) + p u^2 - q_2 u + w_2
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	!  tol				=max error each timestep
	! .. Scalars ..
	!  pp				= order of the splitting method
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  dt				= timestep
	!  modescalereal	= Number to scale after backward FFT
	!  myid				= Process id
	!  ierr				= error code
	!  p_row			= number of rows for domain decomposition
	!  p_col			= number of columns for domain decomposition
	!  plotnum			= number of plot to save
	!  stat				= error indicator when reading inputfile
	! .. Arrays ..
	!  u 			= approximate solution u higher order
	!  v			= approximate solution v higher order
	!  ulow 			= approximate solution u lower order
	!  vlow				= approximate solution v lower order
	!  uhat 			= Fourier transform of u
	!  vhat				= Fourier transform of v
	!  savearray			= stores the realpart to save the data
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction squared
	!  ky				= fourier frequencies in y direction squared
	!  kz				= fourier frequencies in z direction squared
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!  time				= times at which save data
	!  nameconfig		= array to store filename for data to be saved
	!  dpcomm
	!  intcomm
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!  sp				see http://www.2decomp.org/ for more information
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	! Modified from original version by M. Quell
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library

	PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io
!	USE MPI
	! Declare variables
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	INTEGER(kind=4)		::  Nx=512
	INTEGER(kind=4) 	::  Ny=512
	INTEGER(kind=4) 	::  Nz=1
	INTEGER(kind=4) 	::  Nt=100
	INTEGER(kind=4) 	::  plotnum=1000000000
	REAL(kind=8), PARAMETER	::&
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8)		::  Lx=1.0,Ly=1.0,Lz=1.0
	REAL(kind=8)		::  dt=0.001
	REAL(kind=8)		::  tol1=4.0*0.1**12
	REAL(kind=8)		::  time=0.0
	REAL(kind=8)		::  ppp=0.0
	!equation specific
	REAL(kind=8)		::  a=0.03
	REAL(kind=8)		::  d1=0.001
	REAL(kind=8)		::  d2=50.0
	REAL(kind=8)		::  p=0.1
	REAL(kind=8)		::  q1=1.0
	REAL(kind=8)		::  q2=100.0
	REAL(kind=8)		::  w1=1.0
	REAL(kind=8)		::  w2=1.0
	COMPLEX(kind=8)		::  uold,vold, umean,vmean, utemp, vtemp, uhatmp
	INTEGER(kind=4) 	::  cnt=0
	INTEGER(kind=4) 	::  cntmax=100
	REAL(kind=8)		::  tol=0.1**12
	REAL(kind=8)		::  chg=1.0
	COMPLEX(kind=8),	DIMENSION(:), ALLOCATABLE	::  kx,ky
	REAL(kind=8),		DIMENSION(:), ALLOCATABLE	::  x,y
	COMPLEX(kind=8), 	DIMENSION(:,:,:), ALLOCATABLE	::  uhigh,vhigh
	COMPLEX(kind=8), 	DIMENSION(:,:,:), ALLOCATABLE	::  ulow,vlow
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	::  uhat,vhat
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE	:: realfield
	REAL(kind=8) 		::  modescalereal
	INTEGER(kind=4)		::  i,j,k,l,n,m,mm,ll,AllocateStatus,stat,nmax
	INTEGER(kind=4)		::  myid,numprocs,ierr
	TYPE(DECOMP_INFO)	::  decomp
	INTEGER(kind=4)		::  p_row=8, p_col=1
	INTEGER(kind=4)		::  start, finish,  starttot, finishtot, count_rate, ind
	CHARACTER*500		::  nameconfig
	CHARACTER*200		::  numberfile, InputFileName
	! splitting coeffiecents
	REAL(kind=8), DIMENSION(1:2)	::  aa1=(/0.5,0.5/)
	REAL(kind=8), DIMENSION(1:2)	::  bb1=(/1.0,0.0/)
	REAL(kind=8), DIMENSION(1:2)	::  aa2=(/0.0,1.0/)
	REAL(kind=8), DIMENSION(1:2)	::  bb2=(/1.0,0.0/)
	INTEGER(kind=4)		::  pp=2
	INTEGER(kind=4)		::  ss=2
  CHARACTER*500           ::      name
  name='./data/STRANG'

	!initialisation of MPI
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)

	CALL MPI_BCAST(stat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
	IF(myid.eq.0) THEN
		PRINT *,'Nx:',Nx,'Ny:',Ny!,'Nz:',Nz
	END IF
	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	! get information about domain decomposition choosen
	CALL decomp_info_init(Nx,Ny,Nz,decomp) ! physical domain
	! initialise FFT library
	CALL decomp_2d_fft_init
	ALLOCATE(realfield(decomp%xst(1):decomp%xen(1),&
   				decomp%xst(2):decomp%xen(2),&
   				decomp%xst(3):decomp%xen(3)),&
   				uhigh(decomp%xst(1):decomp%xen(1),&
   				decomp%xst(2):decomp%xen(2),&
   				decomp%xst(3):decomp%xen(3)),&
        Vhigh(decomp%xst(1):decomp%xen(1),&
            decomp%xst(2):decomp%xen(2),&
            decomp%xst(3):decomp%xen(3)),&
	    ulow(decomp%xst(1):decomp%xen(1),&
			decomp%xst(2):decomp%xen(2),&
			decomp%xst(3):decomp%xen(3)),&
        vlow(decomp%xst(1):decomp%xen(1),&
            decomp%xst(2):decomp%xen(2),&
            decomp%xst(3):decomp%xen(3)),&
	    uhat(decomp%zst(1):decomp%zen(1),&
            decomp%zst(2):decomp%zen(2),&
            decomp%zst(3):decomp%zen(3)),&
        vhat(decomp%zst(1):decomp%zen(1),&
            decomp%zst(2):decomp%zen(2),&
            decomp%zst(3):decomp%zen(3)),&
		kx(decomp%zst(1):decomp%zen(1)), &
		ky(decomp%zst(2):decomp%zen(2)), &
		x(decomp%xst(1):decomp%xen(1)),&
		y(decomp%xst(2):decomp%xen(2)),&
		stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP

	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	modescalereal=1.0d0/REAL(Nx,KIND(0d0))
	modescalereal=modescalereal/REAL(Ny,KIND(0d0))
	modescalereal=modescalereal/REAL(Nz,KIND(0d0))
	! setup fourier frequencies and grid points
	DO i = 1,1+ Nx/2
		IF ((i.GE.decomp%zst(1)).AND.(i.LE.decomp%zen(1))) THEN
			kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
		END IF
	END DO
	IF ((Nx/2 + 1 .GE.decomp%zst(1)).AND.(Nx/2 + 1 .LE.decomp%zen(1))) THEN
		kx( Nx/2 + 1 ) = 0.0d0
	ENDIF
	DO i = Nx/2+2, Nx
		IF ((i.GE.decomp%zst(1)).AND.(i.LE.decomp%zen(1))) THEN
			Kx( i) = cmplx(0.0d0,-1.0d0)*REAL(1-i+Nx,KIND(0d0))/Lx
		ENDIF
	END DO
	DO i=decomp%xst(1),decomp%xen(1)
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO

	DO j = 1,1+ Ny/2
		IF ((j.GE.decomp%zst(2)).AND.(j.LE.decomp%zen(2))) THEN
			ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
		END IF
	END DO
	IF ((Ny/2 + 1 .GE.decomp%zst(2)).AND.(Ny/2 + 1 .LE.decomp%zen(2))) THEN
		ky( Ny/2 + 1 ) = 0.0d0
	ENDIF
	DO j = Ny/2+2, Ny
		IF ((j.GE.decomp%zst(2)).AND.(j.LE.decomp%zen(2))) THEN
			ky(j) = cmplx(0.0d0,-1.0d0)*REAL(1-j+Ny,KIND(0d0))/Ly
		ENDIF
	END DO
	DO j=decomp%xst(2),decomp%xen(2)
		y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	END DO

	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				uhigh(i,j,k)=0.5+exp(-1.0-(x(i)**2+y(j)**2))
				vhigh(i,j,k)=0.1+exp(-1.0-(x(i)**2+y(j)**2))
			END DO
		END DO
	END DO
	plotnum=0
	! write out using 2DECOMP&FFT MPI-IO routines
	nameconfig=name
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'u'
	WRITE(numberfile,'(i0)') plotnum+1000000000
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//numberfile
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'.datbin'
	realfield=real(uhigh,kind(0d0))
	CALL decomp_2d_write_one(1,realfield,nameconfig)
	!same for v
	nameconfig=name
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'v'
	WRITE(numberfile,'(i0)') plotnum+1000000000
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//numberfile
	ind=index(nameconfig,' ') -1
	nameconfig=nameconfig(1:ind)//'.datbin'
	realfield=real(vhigh,kind(0d0))
	CALL decomp_2d_write_one(1,realfield,nameconfig)
	IF (myid.eq.0) THEN
		PRINT *,'Got initial data, starting timestepping'
	END IF
	CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	CALL system_clock(start,count_rate)
		DO n=1,Nt
		DO l=1,ss
			DO k=decomp%xst(3),decomp%xen(3)
			 DO j=decomp%xst(2),decomp%xen(2)
			  DO i=decomp%xst(1),decomp%xen(1)
						chg=1.0
						cnt=0
						uold=uhigh(i,j,k)
						vold=vhigh(i,j,k)
						DO WHILE ((chg>tol).and.(cnt<cntmax))
						cnt=cnt+1
							utemp=uhigh(i,j,k)
							vtemp=vhigh(i,j,k)
							umean=0.5*(uhigh(i,j,k)+uold)
							vmean=0.5*(vhigh(i,j,k)+vold)
							uhigh(i,j,k)=uold+dt*aa1(l)*(w1+p*umean**2/vmean)
							vhigh(i,j,k)=vold+dt*aa1(l)*(w2+p*umean**2)
							chg=abs((uhigh(i,j,k)-utemp))+abs((vhigh(i,j,k)-vtemp))
						END DO
			END DO
			 END DO
			  END DO
	! solve linear part exactly in Fourier space
			CALL decomp_2d_fft_3d(uhigh,uhat,DECOMP_2D_FFT_FORWARD)
			CALL decomp_2d_fft_3d(vhigh,vhat,DECOMP_2D_FFT_FORWARD)
			DO k=decomp%zst(3),decomp%zen(3)
			 DO j=decomp%zst(2),decomp%zen(2)
			  DO i=decomp%zst(1),decomp%zen(1)
uhat(i,j,k)=exp(dt*bb1(l)*(-q1+d1*(kx(i)**2+ky(j)**2)-a*(kx(i)+ky(j))))*uhat(i,j,k)
vhat(i,j,k)=exp(dt*bb1(l)*(-q2+d2*(kx(i)**2+ky(j)**2)-a*(kx(i)+ky(j))))*vhat(i,j,k)
			END DO
			 END DO
			  END DO
			!dont forget to scale
			CALL decomp_2d_fft_3d(uhat,uhigh,DECOMP_2D_FFT_BACKWARD)
			CALL decomp_2d_fft_3d(vhat,vhigh,DECOMP_2D_FFT_BACKWARD)
			DO k=decomp%xst(3),decomp%xen(3)
			 DO j=decomp%xst(2),decomp%xen(2)
			  DO i=decomp%xst(1),decomp%xen(1)
				uhigh(i,j,k)=uhigh(i,j,k)*modescalereal
				vhigh(i,j,k)=vhigh(i,j,k)*modescalereal
			END DO
			 END DO
			  END DO

		END DO !l
	if(plotnum.eq.n) then
		! write out using 2DECOMP&FFT MPI-IO routines
	  nameconfig=name
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//'u'
	  WRITE(numberfile,'(i0)') plotnum+1000000000
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//numberfile
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//'.datbin'
	  realfield=real(uhigh,kind(0d0))
	  CALL decomp_2d_write_one(1,realfield,nameconfig)
	  !same for v
	  nameconfig=name
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//'v'
	  WRITE(numberfile,'(i0)') plotnum+1000000000
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//numberfile
	  ind=index(nameconfig,' ') -1
	  nameconfig=nameconfig(1:ind)//'.datbin'
	  realfield=real(vhigh,kind(0d0))
    CALL decomp_2d_write_one(1,realfield,nameconfig)
    plotnum=plotnum*2
	end if
END DO !Nt loop
	CALL system_clock(finish,count_rate)
		time=REAL(finish-start)/REAL(count_rate)
		CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
	! clean up
  	CALL decomp_2d_fft_finalize
  	CALL decomp_2d_finalize
 	DEALLOCATE(realfield,uhigh,vhigh,ulow,vlow,&
		  uhat,vhat,&
   		kx,ky,x,y,&
   		stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	IF (myid.eq.0) THEN
	   	PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
	END PROGRAM main


      SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN,
     $                   IWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the gain of a single-input single-output linear system,
C     given its state-space representation (A,b,c,d), and its poles and
C     zeros. The matrix A is assumed to be in an upper Hessenberg form.
C     The gain is computed using the formula
C
C                          -1         IP              IZ
C        g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) ,
C                                     i=1             i=1            (1)
C
C     where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros,
C     respectively, and S0 is a real scalar different from all poles and
C     zeros.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     IP      (input) INTEGER
C             The number of the system poles.  IP >= 0.
C
C     IZ      (input) INTEGER
C             The number of the system zeros.  IZ >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,IP)
C             On entry, the leading IP-by-IP part of this array must
C             contain the state dynamics matrix A in an upper Hessenberg
C             form. The elements below the second diagonal are not
C             referenced.
C             On exit, the leading IP-by-IP upper Hessenberg part of
C             this array contains the LU factorization of the matrix
C             A - S0*I, as computed by SLICOT Library routine MB02SD.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,IP).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (IP)
C             On entry, this array must contain the system input
C             vector b.
C             On exit, this array contains the solution of the linear
C             system ( A - S0*I )x = b .
C
C     C       (input) DOUBLE PRECISION array, dimension (IP)
C             This array must contain the system output vector c.
C
C     D       (input) DOUBLE PRECISION
C             The variable must contain the system feedthrough scalar d.
C
C     PR      (input) DOUBLE PRECISION array, dimension (IP)
C             This array must contain the real parts of the system
C             poles. Pairs of complex conjugate poles must be stored in
C             consecutive memory locations.
C
C     PI      (input) DOUBLE PRECISION array, dimension (IP)
C             This array must contain the imaginary parts of the system
C             poles.
C
C     ZR      (input) DOUBLE PRECISION array, dimension (IZ)
C             This array must contain the real parts of the system
C             zeros. Pairs of complex conjugate zeros must be stored in
C             consecutive memory locations.
C
C     ZI      (input) DOUBLE PRECISION array, dimension (IZ)
C             This array must contain the imaginary parts of the system
C             zeros.
C
C     GAIN    (output) DOUBLE PRECISION
C             The gain of the linear system (A,b,c,d), given by (1).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (IP)
C             On exit, it contains the pivot indices; for 1 <= i <= IP,
C             row i of the matrix A - S0*I was interchanged with
C             row IWORK(i).
C
C     METHOD
C
C     The routine implements the method presented in [1]. A suitable
C     value of S0 is chosen based on the system poles and zeros.
C     Then, the LU factorization of the upper Hessenberg, nonsingular
C     matrix A - S0*I is computed and used to solve the linear system
C     in (1).
C
C     REFERENCES
C
C     [1] Varga, A. and Sima, V.
C         Numerically Stable Algorithm for Transfer Function Matrix
C         Evaluation.
C         Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable in practice and requires
C     O(IP*IP) floating point operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 2002.
C     Partly based on the BIMASC Library routine GAIN by A. Varga.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, state-space representation, transfer function, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, P1, ONEP1
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     P1 = 0.1D0, ONEP1 = 1.1D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   D, GAIN
      INTEGER            IP, IZ, LDA
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*),
     $                   ZR(*)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      INTEGER            I, INFO
      DOUBLE PRECISION   S0, S
C     .. External Functions ..
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT
C     .. External Subroutines ..
      EXTERNAL           MB02RD, MB02SD
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
C     ..
C     .. Executable Statements ..
C
C     For efficiency, the input scalar parameters are not checked.
C
C     Quick return if possible.
C
      IF( IP.EQ.0 ) THEN
         GAIN = ZERO
         RETURN
      END IF
C
C     Compute a suitable value for S0 .
C
      S0 = ZERO
C
      DO 10 I = 1, IP
         S = ABS( PR(I) )
         IF ( PI(I).NE.ZERO )
     $      S = S + ABS( PI(I) )
         S0 = MAX( S0, S )
   10 CONTINUE
C
      DO 20 I = 1, IZ
         S = ABS( ZR(I) )
         IF ( ZI(I).NE.ZERO )
     $      S = S + ABS( ZI(I) )
         S0 = MAX( S0, S )
   20 CONTINUE
C
      S0 = TWO*S0 + P1
      IF ( S0.LE.ONE )
     $   S0 = ONEP1
C
C     Form A - S0*I .
C
      DO 30 I = 1, IP
         A(I,I) = A(I,I) - S0
   30 CONTINUE
C
C     Compute the LU factorization of the matrix A - S0*I
C     (guaranteed to be nonsingular).
C
      CALL MB02SD( IP, A, LDA, IWORK, INFO )
C
C     Solve the linear system (A - S0*I)*x = b .
C
      CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO )
C                        -1
C     Compute c*(S0*I - A) *b + d .
C
      GAIN = D - DDOT( IP, C, 1, B, 1 )
C
C     Multiply by the products in terms of poles and zeros in (1).
C
      I = 1
C
C     WHILE ( I <= IP ) DO
C
   40 IF ( I.LE.IP ) THEN
         IF ( PI(I).EQ.ZERO ) THEN
            GAIN = GAIN*( S0 - PR(I) )
            I = I + 1
         ELSE
            GAIN = GAIN*( S0*( S0  - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 )
            I = I + 2
         END IF
         GO TO 40
      END IF
C
C     END WHILE 40
C
      I = 1
C
C     WHILE ( I <= IZ ) DO
C
   50 IF ( I.LE.IZ ) THEN
         IF ( ZI(I).EQ.ZERO ) THEN
            GAIN = GAIN/( S0 - ZR(I) )
            I = I + 1
         ELSE
            GAIN = GAIN/( S0*( S0  - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 )
            I = I + 2
         END IF
         GO TO 50
      END IF
C
C     END WHILE 50
C
      RETURN
C *** Last line of TB04BX ***
      END


      COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 CDOTU  Krogh   Declared all vars.
C>> 1985-08-02 CDOTU  Lawson  Initial code.
C
C     RETURNS THE DOT PRODUCT FOR COMPLEX CX AND CY, NO CONJUGATION
C     CDOTU = SUM FOR I = 0 TO N-1 OF  CX(LX+I*INCX) * CY(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
      INTEGER N, INCX, INCY, KX, KY, I, NS
      COMPLEX CX(*),CY(*)
C
      CDOTU = (0.,0.)
      IF(N .LE. 0)RETURN
      IF(INCX.EQ.INCY.AND.INCX.GT.0) GO TO 20
      KX = 1
      KY = 1
      IF(INCX.LT.0) KX = 1+(1-N)*INCX
      IF(INCY.LT.0) KY = 1+(1-N)*INCY
          DO 10 I = 1,N
          CDOTU = CDOTU + CX(KX)*CY(KY)
          KX = KX + INCX
          KY = KY + INCY
   10     CONTINUE
      RETURN
   20 CONTINUE
      NS = N*INCX
          DO 30 I=1,NS,INCX
          CDOTU = CDOTU + CX(I)*CY(I)
   30     CONTINUE
      RETURN
      END


! f2py2 norme.f90 -m vect
!   produit vecmodule.c
!
! f2py2 norme.f90 -m vect -h norme.pyf
!   produit norme.pyf, un fichier de signature
!
! compile direct avec gfortran (=>vect.pyd):
! f2py2 -c norme.f90 -m vect --fcompiler=gnu95

! depends on
!C:\msys64\mingw64\lib\python2.7\site-packages/numpy/f2py\src\fortranobject.c
!C:\msys64\mingw64\lib\python2.7\site-packages/numpy/f2py\src\fortranobject.h

subroutine norme ( a , b )
    ! Calcule la norme
    real(8) :: a , b
    real(8) :: c
    c = sqrt ( a*a+b*b )
    print *, " la norme de ( " , a , " , " , b , " ) est " , c
end subroutine norme


SUBROUTINE LUBKSB(A,N,NP,INDX,B)
  USE Precision
  IMPLICIT NONE
  INTEGER :: i,j, ii, ll, n, np, indx(n)
  REAL(kind=long) :: A(NP,NP), B(N), SUM
  II=0
  DO  I=1,N
     LL=INDX(I)
     SUM=B(LL)
     B(LL)=B(I)
     IF (II.NE.0)THEN
        DO  J=II,I-1
           SUM=SUM-A(I,J)*B(J)
        END DO
     ELSE IF (SUM.NE.0.) THEN
        II=I
     ENDIF
     B(I)=SUM
  END DO
  DO  I=N,1,-1
     SUM=B(I)
     IF(I.LT.N)THEN
        DO  J=I+1,N
           SUM=SUM-A(I,J)*B(J)
        END DO
     ENDIF
     B(I)=SUM/A(I,I)
  END DO
  RETURN
END SUBROUTINE LUBKSB


! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

! Basic statistics functionality
module stats
  use globvars
  use arrays, only: arrays_quicksort

  implicit none

  private

  public :: stats_residuals
  public :: stats_mean
  public :: stats_median
  public :: stats_mean_sq_err
  public :: stats_mean_abs_err
  public :: stats_variance
  public :: stats_stdev

contains

  subroutine stats_residuals(data_arr, theor_arr, resid_arr)
    ! Calculate residuals
    !
    ! data_arr :: array of experimental data values
    ! theor_arr :: array of theoretical values, parallel to data_arr
    ! resid_arr :: array to populate with residuals
    real(dp), intent(in) :: data_arr(:), theor_arr(:)
    real(dp), intent(inout) :: resid_arr(:)

    resid_arr(:) = abs(data_arr(:) - theor_arr(:))

  end subroutine stats_residuals

  real(dp) function stats_mean(data_arr, mask) result(val)
    ! Calculate mean
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    integer :: n

    if (present(mask)) then
       n = count(mask)
       val = sum(data_arr, mask=mask) / n
    else
       n = size(data_arr)
       val = sum(data_arr) / n
    end if

  end function stats_mean

  real(dp) function stats_median(data_arr, mask) result(val)
    ! Calculate median
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    real(dp), allocatable :: data_work_arr(:)
    integer :: data_size

    if (present(mask)) then
       data_size = count(mask)
       allocate(data_work_arr(data_size))
       data_work_arr = pack(data_arr, mask)
    else
       data_size = size(data_arr)
       allocate(data_work_arr(data_size))
       data_work_arr(:) = data_arr(:)
    end if

    call arrays_quicksort(data_work_arr, 1, size(data_work_arr))

    if (mod(data_size, 2) .eq. 0) then
       val = 0.5_dp * (data_work_arr(data_size / 2) + &
            data_work_arr(data_size / 2 + 1))
    else
       val = data_work_arr( (data_size - 1) / 2 + 1 )
    end if

    deallocate(data_work_arr)

  end function stats_median

  real(dp) function stats_mean_abs_err(resid_arr, mask) result(val)
    ! Calculate mean absolute error from residuals
    !
    ! resid_arr :: residual arrays
    ! mask :: logical masking array
    real(dp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    integer :: n

    if (present(mask)) then
       n = count(mask)
       val = sum(resid_arr, mask=mask) / n
    else
       n = size(resid_arr)
       val = sum(resid_arr) / n
    end if

  end function stats_mean_abs_err

  real(dp) function stats_mean_sq_err(resid_arr, mask) result(val)
    ! Calculate mean squared error from residuals
    !
    ! resid_arr :: residual arrays
    ! mask :: logical masking array
    real(dp), intent(in) :: resid_arr(:)
    logical, intent(in), optional :: mask(:)

    integer :: n

    if (present(mask)) then
       n = count(mask)
       val = sum(resid_arr**2, mask=mask) / n
    else
       n = size(resid_arr)
       val = sum(resid_arr**2) / n
    end if

  end function stats_mean_sq_err

  real(dp) function stats_variance(data_arr, mask) result(val)
    ! Calculate variance
    !
    ! data_arr :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    real(dp) :: mean
    integer :: n

    if (present(mask)) then
       n = count(mask)
       mean = stats_mean(data_arr, mask=mask)
       ! Biased sample variance
       val = sum(data_arr**2, mask=mask) / n - mean**2
       ! Convert to unbiased sample variance
       val = n / (n - 1.0_dp) * val
    else
       n = size(data_arr)
       mean = stats_mean(data_arr)
       val = sum((data_arr - mean)**2) / (n - 1)
    end if

  end function stats_variance

  real(dp) function stats_stdev(data_arr, mask) result(val)
    ! Compute standard deviation
    !
    ! data :: array of data values
    ! mask :: logical masking array
    real(dp), intent(in) :: data_arr(:)
    logical, intent(in), optional :: mask(:)

    if (present(mask)) then
       val = sqrt(stats_variance(data_arr, mask=mask))
    else
       val = sqrt(stats_variance(data_arr))
    end if

  end function stats_stdev

end module stats


! 1. Write a function that returns the largest element in a list.

    !This program has two solutions- one with a bounded list, and one with an unbounded one.

    program Exercises
    implicit none
    integer :: list4(4)
    integer :: list(10);
    integer :: largestElement

    list4 = (/ 23, 75, 198, 3 /)
    largestElement = getLargestElement$fixed4(list4)
    print '(A, I0)', 'The largest element in the first list is: ', largestElement

    list = (/ 3, 215, 9, 5, 88, 22, 545, 3, 7, 1 /)
    largestElement = getLargestElement$unbounded(list)
    print '(A, I0)', 'The largest element is in the second list is: ', largestElement

    contains

    function getLargestElement$fixed4(list) result(r)
        integer, intent(in) :: list(4)
        integer :: r, i, listSize
        r = list(1)
        do i=2,4
            if (list(i) > r) then
                r = list(i)
            end if
        end do
    end function getLargestElement$fixed4

    ! Alternatively, return the largest element of an array of unbounded size.
    ! This uses an F90 "assumed shape array".
    function getLargestElement$unbounded(list) result(r)

        ! The dimension keyword allows you to declare an array with unbounded upper limit.
        ! I've heard mixed opinions about whether assumed shape arrays are just as good for performance. In general, it's probably
        ! desirable to declare arrays with an explicit size when possible so that the compiler can go to town on it. However, this works if
        ! you can't structure things that way.
        integer, dimension(1:), intent(in) :: list
        integer :: r
        integer :: i
        integer :: listSize

        listSize = size(list) ! The size keyword is available through F90.
        r = list(1)
        if (listSize .gt. 1) then
            do i=2,size(list)
                if (list(i) > r) then
                    r = list(i)
                end if
            end do
        end if

    end function getLargestElement$unbounded

    end program Exercises


!
! Nyx code units are defined as:
!      Length [Mpc]
!      Velocity [km/s]
!      Mass [M_sun]
!      (+ Kelvin for temperature)
!
! Fundamental constants are taken from Phys. Rev. D 86 (2012), see
!          pdg.lbl.gov/2012/reviews/rpp2012-rev-phys-constants.pdf
!          pdg.lbl.gov/2012/reviews/rpp2012-rev-astrophysical-constants.pdf
!

module fundamental_constants_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  ! Relation of our code units & CGS:
  real(rt), parameter :: M_unit = 1.9884d33     ! M_sun
  real(rt), parameter :: L_unit = 3.0856776d24  ! Mpc
  real(rt), parameter :: V_unit = 1.d5          ! km/s
  real(rt), parameter :: T_unit = L_unit/V_unit ! time unit

  !
  ! Fundamental constants
  !
  real(rt), parameter :: Gconst = 6.6743e-8_rt * &            ! Newton [g^-1*s^-2*cm^3]
                                  M_unit*T_unit**2/L_unit**3

  real(rt), parameter :: k_B    = 1.3806504e-16_rt * &        ! Boltzmann [g*cm^2/s^2*K]
                                  T_unit**2/(M_unit*L_unit**2)

  real(rt), parameter :: hbar   = 1.054571628e-27_rt * &      ! Planck/2pi [g*cm^2/s]
                                  T_unit/(M_unit*L_unit**2)

  real(rt), parameter :: n_A    = 6.02214179e23_rt * M_unit   ! Avogadro's number [mol^-1]

  real(rt), parameter :: m_proton = 1.6726231e-24_rt / M_unit ! Proton mass [g]

  real(rt), parameter :: c_light = 2.99792458e10_rt / V_unit  ! Speed of light [cm/s]

  real(rt), parameter :: Hubble_const = 100._rt              ! Hubble constant / h

  !
  ! Useful quantities and conversions
  !
  real(rt), parameter :: mp_over_kb = m_proton/k_B

  real(rt), parameter :: density_to_cgs = M_unit / L_unit**3

  ! For internal energy
  real(rt), parameter :: e_to_cgs = V_unit**2

  ! For source terms we convert [erg/(s*cm^3) = g/(s^3*cm)] into code units
  real(rt), parameter :: heat_from_cgs = L_unit*(T_unit**3 / M_unit)

  ! Keep these for now for JF H/C files (not used elsewhere)
  ! energy per volume from code units to cgs
  real(rt), parameter :: epv_to_cgs = e_to_cgs * density_to_cgs
  real(rt), parameter :: Mpc_to_km = 3.08568025d19
  ! energy per volume per time from cosmo to cgs
  real(rt), parameter :: epvpt_to_cgs = epv_to_cgs / T_unit

end module fundamental_constants_module


! Sample solution to the problem posed in Lab 11.

program main

    use omp_lib
    use random_util2, only: init_random_seed

    implicit none
    integer :: seed
    real (kind=8), allocatable :: x(:)
    real (kind=8) :: mean
    integer :: i,n

    print *, "input n"
    read *, n
    allocate(x(n))
    print *, "input seed"
    read *, seed

    call init_random_seed(seed)

    call random_number(x)
    mean = 0.d0
    !$omp parallel do reduction(+:mean)
    do i=1,n
        mean = mean + x(i)
        enddo
    mean = mean / n
    print *, "The mean is: ",mean

    print *, "The difference from the true mean 0.5 is ",abs(mean - 0.5d0)
    print *, "1/sqrt(n) = ", 1.d0/sqrt(float(n))

end program main


      DOUBLE PRECISION FUNCTION DXPARG (L)
      INTEGER L
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 DXPARG Krogh  Moved external statement up for mangle.
C>> 1994-10-20 DXPARG Krogh  Changes to use M77CON
C>> 1993-05-06 DXPARG WVS JPL Conversion from NSWC to Math 77
c--D replaces "?": ?XPARG
C -------------------------------------------------------------------
C     IF L = 0 THEN  DXPARG(L) = THE LARGEST POSITIVE W FOR WHICH
C     EXP(W) CAN BE COMPUTED.
C
C     IF L IS NONZERO THEN  DXPARG(L) = THE LARGEST NEGATIVE W FOR
C     WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO.
C
C     NOTE... ONLY AN APPROXIMATE VALUE FOR DXPARG(L) IS NEEDED.
C -------------------------------------------------------------------
      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH
      DOUBLE PRECISION FAC, XMAX, XMIN
      SAVE XMAX, XMIN
      DATA XMAX /-1.0D0/
C
      IF (XMAX .LT. 0.0) THEN
         FAC = 1.0D0 - D1MACH(3)
         XMAX = FAC * LOG(D1MACH(2))
         XMIN = FAC * LOG(D1MACH(1))
      END IF
C
      IF (L .NE. 0) THEN
         DXPARG = XMIN
      ELSE
         DXPARG = XMAX
      END IF
      RETURN
      END


SUBROUTINE cgsolve(g,q,sol)

!-------------------------------------------------------------
!
!  Perform a simple conjugate gradient solution
!
!-------------------------------------------------------------

USE invar
USE solvar
USE timevar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g
INTEGER :: it, neq
REAL*8 :: alf, bet, dfmx, tmp, qnorm
REAL*8, DIMENSION((ordsq*nx*ny)), INTENT(IN) :: q
REAL*8, DIMENSION((ordsq*nx*ny)), INTENT(OUT) :: sol
REAL*8, DIMENSION((ordsq*nx*ny)) :: res, sd, tmp1, sold

! Set the timing point
told = tjmat

neq = ordsq*nx*ny
WRITE (8,*) " Conjugate Gradient iterative solution ..."
WRITE(8,'(2X,A)') "Error based on solution residual"
! Initialize my guess
sol = 0.0
res = q
sd = res
!qnorm = SQRT(DOT_PRODUCT(q,q))
!qnorm = MAXVAL(ABS(q))
tmp = DOT_PRODUCT(res,res)
DO it = 1, itmx
   ! The CG steps...should be optimized later or use outside solver
   tmp1 = MATMUL(jmat,sd)
   alf = tmp/(DOT_PRODUCT(sd,tmp1))
   sol = sol + alf*sd
   res = res-alf*tmp1
   bet = 1.0/tmp
   tmp = DOT_PRODUCT(res,res)
   bet = tmp*bet
   sd  = res + bet*sd

   ! Check convergence between the iterates.
   ! Error based on the residual and possibly the RHS
!   dfmx = SQRT(tmp)/qnorm
!   dfmx = (MAXVAL(ABS(res)))/qnorm
!   dfmx = MAXVAL(ABS(res))
   dfmx = SQRT(tmp)

   ! Get iteration time
   CALL CPU_TIME(titer)

   IF (dfmx > err .AND. it < itmx) THEN

! DON'T USE THIS WHEN DETERMINING ERROR WITH 2-NORM
! Report the change in the error
!      ndx = MAXLOC(ABS(tmp2))
!      indx = ndx(1) - 1
!      ! Need to back out the values for the position and moments
!      jd = (indx/(nx*ordsq)) + 1
!      id = (MOD(indx,(nx*ordsq))/ordsq) + 1
!      indx2 = indx - ((jd-1)*nx + (id-1))*ordsq
!      kd = indx2/order
!      ld = MOD(indx2,order)
!      WRITE(8,121) g, it, id, jd, kd, ld, dfmx, sol(indx), titer-told

      WRITE (8,122) g, it, dfmx, titer-told

      ! Reset the timing point
      told = titer
      CYCLE

   ELSE IF (dfmx < err) THEN
      WRITE(8,*)
      WRITE(8,*) " Group ", g, "converged in ", it, " iterations"
      WRITE(8,'(2X,A,ES11.3,A,ES11.3)') "Maximum error estimated: ", dfmx, " < ", err
      WRITE(8,'(2X,A,F9.3,A)') "Final iteration time ", titer-told, " seconds"
      cnvf(g) = 1
      EXIT
   ELSE IF (it == itmx) THEN
      WRITE(8,*)
      WRITE(8,*) " Group ", g, " did not converge in maximum number of iterations ", itmx
      WRITE(8,*) " Max error = ", dfmx
      cnvf(g) = 0
      EXIT
   END IF

   ! Error based on successive iterates
   ! dfmx = -1.0
   ! DO i = 1, neq
   !    IF (sold(i) >= tolr) THEN
   !       df = ABS((sol(i) - sold(i))/sold(i))
   !    ELSE
   !       df = ABS(sol(i) - sold(i))
   !    END IF
   !    IF (df > dfmx) dfmx = df
   !  END DO

   ! IF (dfmx > err .AND. it < itmx) THEN
   !    res = res - alf*tmp1
   !    bet = DOT_PRODUCT(res,res)
   !    bet = bet/tmp
   !    sd = res + bet*sd
   !    sold = sol
   !    CYCLE
   ! ELSE IF (dfmx < err) THEN
   !    WRITE (8,*)
   !    WRITE (8,*) " Group ", g, " converged in ", it, " iterations"
   !    WRITE (8,'(2X,A,ES11.3,A,ES11.3)') "Maximum error estimated: ", dfmx, " < ", err
   !    cnvf(g) = 1
   !    EXIT
   ! ELSE IF (it == itmx) THEN
   !    WRITE(8,*)
   !    WRITE(8,*) " Group ", g, " did not converge in maximum number of iterations ", itmx
   !    WRITE(8,*) " Max error = ", dfmx
   !    cnvf(g) = 0
   !    EXIT
   ! END IF
END DO

!121 FORMAT(2X,'Gr',I3,' It ',I5,' Pos ',2I4,' Mom ',2I2,' DfMx ',ES11.3,' Flx ',ES11.3, '  Time(s) ', F9.3)
122 FORMAT(2X,'Gr',I3,' It ',I5,' Dfmx ',ES11.3,'  Time(s) ',F9.3)
RETURN
END SUBROUTINE cgsolve


! { dg-do compile }
! { dg-options "-Ofast" }
module m
  implicit none
  private
  save

  integer, parameter, public :: &
    ii4          = selected_int_kind(6), &
    rr8          = selected_real_kind(13)

  integer (ii4), dimension(40,40,199), public :: xyz
  public :: foo
contains
  subroutine foo(a)
    real (rr8), dimension(40,40), intent(out) :: a
    real (rr8), dimension(40,40) :: b
    integer (ii4), dimension(40,40) :: c
    integer  i, j

    do i=1,20
      b(i,j) = 123 * a(i,j) + 34 * a(i,j+1) &
             + 34 * a(i,j-1) + a(i+1,j+1) &
             + a(i+1,j-1) + a(i-1,j+1) &
             + a(i-1,j-1)
      c(i,j) = 123
    end do

    where ((xyz(:,:,2) /= 0) .and. (c /= 0))
      a = b/real(c)
    elsewhere
      a = 456
    endwhere
 end subroutine foo
end module m


program m
    use percolation
    use utilities
    implicit none

    integer :: num_Ls, i, num_samples, fileunit
    integer, dimension(:), allocatable :: Ls
    real(kind=dp) :: x1, x2, tolerance, nu, slope, const
    real(kind=dp), dimension(:,:), allocatable :: invPI
    real(kind=dp), dimension(:), allocatable :: diff, diffapprox
    character(len=:), allocatable :: filename

    Ls = [(2**i, i = 4, 9)]
    num_Ls = size(Ls)

    x1 = 0.8; x2 = 0.3
    num_samples = 2**16; tolerance = 0.0001d0

    allocate(invPI(num_Ls, 2))

    invPI(:,1) = [(spanning_probability_inverse(x1, Ls(i), num_samples/Ls(i), tolerance), &
                   i = 1, num_Ls)]
    invPI(:,2) = [(spanning_probability_inverse(x2, Ls(i), num_samples/Ls(i), tolerance), &
                   i = 1, num_Ls)]

    diff = invPI(:,1) - invPI(:,2)

    call linfit(log(1.0d0*Ls), log(diff), slope, const)
    nu = -1/slope
    diffapprox = exp(const) * Ls**slope

    open(newunit=fileunit, file="tmp/m.dat", status="replace")
    do i = 1, num_Ls
        write(unit=fileunit, fmt=*) Ls(i), diff(i), diffapprox(i)
    end do
    close(unit=fileunit)

    open(newunit=fileunit, file="tmp/m_nu.dat", status="replace")
    write(unit=fileunit, fmt="(f0.3)") nu
    close(unit=fileunit)

end program m


module mpow
  implicit none

contains

  !
  ! Description:
  !
  !   ME = trans(MA)^m
  !
  !

  subroutine mpow_dense(trans, n, MA, lda, ME, lde, m, info)
    character, intent(in) :: trans
    integer, intent(in) :: n, lda, lde, m
    double precision, intent(in) :: MA(1:lda,1:n)
    double precision, intent(out) :: ME(1:lde,1:n)
    integer, intent(out) :: info

    integer :: i, y
    integer :: ipiv(1:n)
    double precision :: MX(1:n,1:n), MT(1:n,1:n)

    info = 0
    if (m < 0) then
      select case (trans)
        case ('N', 'n')
          MT(1:n,1:n) = MA(1:n,1:n)
        case ('T', 't')
          MT(1:n,1:n) = transpose(MA(1:n,1:n))
      end select

      MX(1:n,1:n) = 0.0d0
      do i = 1, n
        MX(i,i) = 1.0d0
      end do
      call dgesv(n, n, MT, n, ipiv, MX, n, info)
      y = -m
    else
      select case (trans)
        case ('N', 'n')
          MX(1:n,1:n) = MA(1:n,1:n)
        case ('T', 't')
          MX(1:n,1:n) = transpose(MA(1:n,1:n))
      end select
      y = m
    end if

    ME(1:n,1:n) = 0.0d0
    do i = 1, n
      ME(i,i) = 1.0d0
    end do

    do while (y /= 0)
      if (mod(y,2) == 1) then
        MT(1:n,1:n) = ME(1:n,1:n)
        call dgemm('N', 'N', n, n, n, 1.0d0, MX, n, MT, n, 0.0d0, ME, lde)
      end if
      y = y / 2
      call dgemm('N', 'N', n, n, n, 1.0d0, MX, n, MX, n, 0.0d0, MT, n)
      MX(1:n,1:n) = MT(1:n,1:n)
    end do
  end subroutine mpow_dense

  subroutine mpow_csr(trans, n, spMA, rowptr, colind, nnz, ME, lde, m, info)
    use sparse
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, lde, m
    integer, intent(in) :: rowptr(1:*), colind(1:*)
    double precision, intent(in) :: spMA(1:*)
    double precision, intent(out) :: ME(1:lde,1:n)
    integer, intent(out) :: info

    double precision, allocatable :: MA(:,:)

    allocate(MA(1:n,1:n))

    call csr_to_dense(n, n, spMA, rowptr, colind, nnz, MA, n)
    call mpow_dense(trans, n, MA, n, ME, lde, m, info)

    deallocate(MA)
  end subroutine mpow_csr

  subroutine mpow_csc(trans, n, spMA, colptr, rowind, nnz, ME, lde, m, info)
    use sparse
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, lde, m
    integer, intent(in) :: colptr(1:*), rowind(1:*)
    double precision, intent(in) :: spMA(1:*)
    double precision, intent(out) :: ME(1:lde,1:n)
    integer, intent(out) :: info

    double precision, allocatable :: MA(:,:)

    allocate(MA(1:n,1:n))

    call csc_to_dense(n, n, spMA, colptr, rowind, nnz, MA, n)
    call mpow_dense(trans, n, MA, n, ME, lde, m, info)

    deallocate(MA)
  end subroutine mpow_csc

  subroutine mpow_coo(trans, n, spMA, rowind, colind, nnz, ME, lde, m, info)
    use sparse
    character, intent(in) :: trans
    integer, intent(in) :: n, nnz, lde, m
    integer, intent(in) :: rowind(1:*), colind(1:*)
    double precision, intent(in) :: spMA(1:*)
    double precision, intent(out) :: ME(1:lde,1:n)
    integer, intent(out) :: info

    double precision, allocatable :: MA(:,:)

    allocate(MA(1:n,1:n))

    call coo_to_dense(n, n, spMA, rowind, colind, nnz, MA, n)
    call mpow_dense(trans, n, MA, n, ME, lde, m, info)

    deallocate(MA)
  end subroutine mpow_coo

end module mpow


      PROGRAM xtred2
C     driver for routine tred2
      INTEGER NP
      PARAMETER(NP=10)
      INTEGER i,j,k,l,m
      REAL a(NP,NP),c(NP,NP),d(NP),e(NP),f(NP,NP)
      DATA c/5.0,4.3,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,-4.0,
     *     4.3,5.1,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,-3.0,
     *     3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,-2.0,
     *     2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,-1.0,
     *     1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,0.0,
     *     0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,1.0,
     *     -1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,2.0,
     *     -2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,3.0,
     *     -3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0,4.0,
     *     -4.0,-3.0,-2.0,-1.0,0.0,1.0,2.0,3.0,4.0,5.0/
      do 12 i=1,NP
        do 11 j=1,NP
          a(i,j)=c(i,j)
11      continue
12    continue
      call tred2(a,NP,NP,d,e)
      write(*,'(/1x,a)') 'Diagonal elements'
      write(*,'(1x,5f12.6)') (d(i),i=1,NP)
      write(*,'(/1x,a)') 'Off-diagonal elements'
      write(*,'(1x,5f12.6)') (e(i),i=2,NP)
C     check transformation matrix
      do 16 j=1,NP
        do 15 k=1,NP
          f(j,k)=0.0
          do 14 l=1,NP
            do 13 m=1,NP
              f(j,k)=f(j,k)
     *             +a(l,j)*c(l,m)*a(m,k)
13          continue
14        continue
15      continue
16    continue
C     how does it look?
      write(*,'(/1x,a)') 'Tridiagonal matrix'
      do 17 i=1,NP
        write(*,'(1x,10f7.2)') (f(i,j),j=1,NP)
17    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xtred2.for


PROGRAM Day15
    integer :: arg_count
    integer :: first
    integer :: second
    integer :: num_same
    character(len=16) :: arg

    arg_count = COMMAND_ARGUMENT_COUNT()

    IF (arg_count /= 2) THEN
        PRINT *, "Two arguemnts are expected"
        CALL EXIT(1)
    END IF

    CALL GETARG(1, arg)
    READ(arg, *) first

    CALL GETARG(2, arg)
    READ(arg, *) second

    num_same = 0

    DO i = 1, 40000000, 1
        first = MOD(int8(first) * 16807, 2147483647)
        second = MOD(int8(second) * 48271, 2147483647)

        IF (IAND(first, z'FFFF') == IAND(second, z'FFFF')) THEN
            num_same = num_same + 1
        END IF
    END DO

    PRINT *, num_same
END PROGRAM Day15