C      FGHEVEN
C      F. Gogtas, G.G. Balint-Kurti and C.C. Marston,
C      QCPE Program No. 647, (1993).
C
C     ***************************************************************
C     This program solves one dimensional Schrodinger equation for
C     bound state eigenvalues and eigenfunctions corresponding to a
C     potential V(x).
C
C     The Fourier Grid Hamiltonian method is used in the program.
C     This method is fully described in:
C     C.C. Marston and G.G.Balint-Kurti, J.Chem. Phys.,91,3571(1989).
C     and
C     G.G. Balint-Kurti, R.N. Dixon and C.C. Marston, Internat. Rev.
C     Phys. Chem.,11, 317 (1992).
C
C     The program uses an even number of grid points. The Hamiltonian
C     matrix elements are calculated using analytic formula described
C     in the second of the above references.
C
C     The analytical Hamiltonian expression given in the reference
C     contains a small error.  The formula should read:
C
C                H(i,j) = {(h**2)/(4*m*(L**2)} *
C                          [(N-1)(N-2)/6 + (N/2)] + V(Xi),   if i=j
C
C                H(i,j) = {[(-1)**(i-j)] / m } *
C                          { h/[2*L*sin(pi*(i-j)/N)]}**2 ,     if i#j
C
C     The eigenvalues of the Hamiltonian matrix which lie below the
C     asymptotic (large x) value of V(x) correspond to the bound state
C     energies. The corresponding eigenvectors are the representation
C     of the bound state wavefunctions on a regular one dimensional
C     grid.
C
C     The user must supply a self contained subroutine VSUB(X,V)
C     which is called with a value of X and returns the value of the
C     potential in V.
C
C     As supplied the program uses a Morse potential with parameters
C     chosen
C     to represent the HF molecule.
C
C     The Program should work on any computer
C     Programming language used                    : Fortran77
C     Memory required to execute with typical data : 1 Mbyte
C
C     To run the program on a SUN workstation (or any Unix based system)
C     First type:
C        f77 -o fgheven fgheven.f
C     to create an executable program (fgheven).
C     Then type:
C        fgheven > fgheven.out &
C     to run the program.
C
C     The dimensions of the arrays generally depend on the number of
C     grid
C     points used.  This number NX is set in a PARAMETER statement.
C     The following arrays represent  :
C
C        XA  : X-coordinates i.e. position on a grid.
C
C        AR  : The Hamiltonian Matrix
C
C        WCH : The eigenvalues for respective energy levels.
C
C        ZR  : The eigenvectors (X,Y); where
C                                      X : Wavefunction.
C                                      Y : Energy level.
C    The folowing data constans represent :
C        ZMA, ZMB : Mass of atoms.
C        R0       : Equilibrium bond separation
C        NPRIN    : 0 or 1 for eigenvalue or eigenvector respectively
C        NWRIT    : Number of eigenvales/eigenvectors to be printed
C        RMIN     : Starting point of grid
C        RMAX     : End point of grid
C        ZL       : Grid length
C        DX       : Grid spacings
C
C       All quantities in au (unless otherwise stated)
C     ****************************************************************
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NX=128)
C
C.....Declare arrays.
      DIMENSION XA(NX),AR(NX,NX),WCH(NX),ZR(NX,NX)
      DIMENSION FV1(NX),FV2(NX)
C
C.....Variable data input.
      DATA ZMA/1836.9822D0/
      DATA ZMB/34629.61319D0/
      DATA R0/1.7329D0/
      DATA PI/3.141592653589793D0/
      DATA NPRIN/1/
      DATA NWRIT/10/
C
C....Test that NX is even
      ITEST=MOD(NX,2)
      IF(ITEST.NE.0) THEN
        WRITE(6,*)' **** NX MUST BE EVEN-FATAL ERROR  ****'
        STOP
      END IF
C
C.....Set up grid
      WRITE(6,*)'Grid paremeters:'
      WRITE(6,*)'   Number of grid poins    = ',NX
      RMIN=R0*0.2D0
      RMAX=R0*3.0D0
      ZL=(RMAX-RMIN)
      WRITE(6,*)'   Grid length             = ',ZL
      DX=ZL/DFLOAT(NX)
      WRITE(6,*)'   Grid spacings           = ',DX
C.....Print mass of atoms A and B
      WRITE(6,*)'Mass of atoms:'
      WRITE(6,*)'   Atomic mass of atom A      = ',ZMA
      WRITE(6,*)'   Atomic mass of atom B      = ',ZMB
C.....Compute reduced mass.
      ZMU=ZMA*ZMB/(ZMA+ZMB)
      WRITE(6,*)'   Reduced mass of AB      = ',ZMU
C
C.....Compute contants:
      PSQ=PI*PI
      CONST1=PSQ/(ZMU*(ZL**2))
      NFACT1=(NX-1)*(NX-2)
      NFACT2=(NX-2)/2
      CONST2=CONST1*(DFLOAT(NFACT1)/6.0D0 +1.0D0+DFLOAT(NFACT2))
      DARG=PI/DFLOAT(NX)
C
C.....Now compute Hamiltonian matrix:
      X=RMIN
      DO 003 I=1,NX
         XA(I)=X
       DO 004 J=1,I
          IJD=(I-J)
        IF(IJD.EQ.0)THEN
          AR(I,J)=CONST2
        ELSE
          RATIO=1.0D0/DSIN(DARG*DFLOAT(IJD))
          AR(I,J)=((-1)**IJD)*CONST1*(RATIO**2)
        END IF
 004  CONTINUE
C.....Find the potential value at x
      CALL VSUB(X,VV)
C.....Add the potential value when the kronecker delta function
C.....equals to one, i.e. when I and J are equal
        AR(I,I)=AR(I,I)+VV
        X=X+DX
 003  CONTINUE
C.....Now fill out Hamiltonian matrix.
      DO 006 I=1,NX
       DO 007 J=1,I
        AR(J,I)=AR(I,J)
007    CONTINUE
006   CONTINUE
C.....Now call eigenvalue solver.
      call flush(6)
      CALL RS(NX,NX,AR,WCH,NPRIN,ZR,FV1,FV2,IERR)
C.....Print out eigenvalues and eigenvectors.
      WRITE(6,12)
12    FORMAT(/)
      WRITE(6,*)' The first',NWRIT,' energy levels for AB molecule '
      DO 009 I=1,NWRIT
       WRITE(6,*)' ENERGY LEVEL NO ',I,' EIGENVALUE= ',WCH(I)
 009  CONTINUE
      WRITE(6,12)
      WRITE(6,*)' THE CORRESPONDING EIGENFUNCTIONS ARE:'
      DO 010 I=1,NWRIT
       WRITE(6,*)' ENERGY LEVEL NO ',I,' EIGENVALUE= ',WCH(I)
       IF (NPRIN.EQ.1) THEN
       DO 011 J=1,NX
         WRITE(6,*)' R = ',XA(J),' WAVEFUNCTION=',ZR(J,I)
 011   CONTINUE
       ENDIF
 010  CONTINUE
      STOP
      END
C
C
      SUBROUTINE VSUB(X,V)
C     **************************************************************
C.....SUBROUTINE TO COMPUTE POTENTIAL ENERGY AT SEPERATION X (IN
C.....ATOMIC UNITS). THE VALUE OF THE POTENTIAL IS RETURNED IN V,
C.....AGAIN IN ATOMIC UNITS.THE POTENTIAL ENERGY IS ASSUMED TO
C..... BE A MORSE CURVE:V(X) = DHART * (EXP(-BETA*(X-R0)) - 1)**2
C..... THE FOLLOWING DATA CONSTANTS REPRESENT :
C.....    DHART : THE DISSOCIATION ENERGY FOR THE GIVEN MOLECULE
C.....    BETA  : THE EXPONENTIAL PARAMETER
C.....    R0    : THE BOND LENGTH AT EQUILIBRIUM FOR GIVEN MOLECULE
C     **************************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DATA DHART/0.2250073497D0/
      DATA BETA/1.1741D0/
      DATA R0/1.7329D0/
C.....Set morse curve parameters.
      ARG=X-R0
      ARG=-BETA*ARG
      EF=DEXP(ARG)
      EF=1.0D0-EF
      EF=EF*EF
      V=DHART*EF
      RETURN
      END
C
C
      SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N)
C     ****************************************************************
C     THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
C     SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
C     TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
C     OF A REAL SYMMETRIC MATRIX.
C
C     ON INPUT :
C
C        N,M  MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
C        ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C        DIMENSION STATEMENT,
C        N  IS THE ORDER OF THE MATRIX  A,
C        A  CONTAINS THE REAL SYMMETRIC MATRIX,
C        MATZ  IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
C        ONLY EIGENVALUES ARE DESIRED,  OTHERWISE IT IS SET TO
C        ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
C
C     ON OUTPUT :
C
C        W  CONTAINS THE EIGENVALUES IN ASCENDING ORDER,
C        Z  CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO,
C        IERR  IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN
C        ERROR COMPLETION CODE DESCRIBED IN SECTION 2B OF THE
C        DOCUMENTATION.  THE NORMAL COMPLETION CODE IS ZERO,
C        FV1  AND  FV2  ARE TEMPORARY STORAGE ARRAYS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C    *******************************************************************
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 IF (MATZ .NE. 0) GO TO 20
C     ********** FIND EIGENVALUES ONLY **********
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     ********** FIND BOTH EIGENVALUES AND EIGENVECTORS **********
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
   50 RETURN
C     ********** LAST CARD OF RS **********
      END
C
C
      SUBROUTINE TRED1(NM,N,A,D,E,E2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NM,N),D(N),E(N),E2(N)
C     ***************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX
C     TO A SYMMETRIC TRIDIAGONAL MATRIX USING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT :
C
C        A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS-
C          FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER
C          TRIANGLE.  THE FULL UPPER TRIANGLE OF A IS UNALTERED,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E.
C          E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ****************************************************************
C
      DO 100 I = 1, N
  100 D(I) = A(I,I)
C     ********** FOR I=N STEP -1 UNTIL 1 DO -- **********
      DO 300 II = 1, N
         I = N + 1 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 1) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(A(I,K))
C
         IF (SCALE .NE. 0.0D0) GO TO 140
  130    E(I) = 0.0D0
         E2(I) = 0.0D0
         GO TO 290
C
  140    DO 150 K = 1, L
            A(I,K) = A(I,K) / SCALE
            H = H + A(I,K) * A(I,K)
  150    CONTINUE
C
         E2(I) = SCALE * SCALE * H
         F = A(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         A(I,L) = F - G
         IF (L .EQ. 1) GO TO 270
         F = 0.0D0
C
        DO 240 J = 1, L
            G = 0.0D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + A(J,K) * A(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + A(K,J) * A(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * A(I,J)
  240    CONTINUE
C
         H = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = A(I,J)
            G = E(J) - H * F
            E(J) = G
C
            DO 260 K = 1, J
               A(J,K) = A(J,K) - F * E(K) - G * A(I,K)
  260    CONTINUE
C
  270    DO 280 K = 1, L
  280    A(I,K) = SCALE * A(I,K)
C
  290    H = D(I)
         D(I) = A(I,I)
         A(I,I) = H
  300 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED1 **********
      END
C
C
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NM,N),D(N),E(N),Z(NM,N)
C     ****************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2,
C     NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A
C     SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING
C     ORTHOGONAL SIMILARITY TRANSFORMATIONS.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        A CONTAINS THE REAL SYMMETRIC INPUT MATRIX.  ONLY THE
C          LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED.
C
C     ON OUTPUT :
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL
C          MATRIX IN ITS LAST N-1 POSITIONS.  E(1) IS SET TO ZERO,
C
C        Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX
C          PRODUCED IN THE REDUCTION,
C
C        A AND Z MAY COINCIDE.  IF DISTINCT, A IS UNALTERED.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     *************************************************************
      DO 100 I = 1, N
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
C
      IF (N .EQ. 1) GO TO 320
C     ********** FOR I=N STEP -1 UNTIL 2 DO -- **********
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         IF (L .LT. 2) GO TO 130
C     ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) **********
         DO 120 K = 1, L
  120    SCALE = SCALE + DABS(Z(I,K))
C
         IF (SCALE .NE. 0.0D0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
C
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
C
         F = Z(I,L)
         G = -DSIGN(DSQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0D0
C
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / H
            G = 0.0D0
C     ********** FORM ELEMENT OF A*U **********
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
C
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
C
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
C     ********** FORM ELEMENT OF P **********
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
C
         HH = F / (H + H)
C     ********** FORM REDUCED A **********
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
C
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
C
  290    D(I) = H
  300 CONTINUE
C
  320 D(1) = 0.0D0
      E(1) = 0.0D0
C     ********** ACCUMULATION OF TRANSFORMATION MATRICES **********
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0D0) GO TO 380
C
         DO 360 J = 1, L
            G = 0.0D0
C
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
C
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
C
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0D0
         IF (L .LT. 1) GO TO 500
C
         DO 400 J = 1, L
            Z(I,J) = 0.0D0
            Z(J,I) = 0.0D0
  400    CONTINUE
C
  500 CONTINUE
C
      RETURN
C     ********** LAST CARD OF TRED2 **********
      END
C
C
      SUBROUTINE TQLRAT(N,D,E2,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION D(N),E2(N)
      REAL*8 MACHEP
C     *****************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT,
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT :
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX'
C
C        E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT :
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     **************************************************************
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C
      MACHEP = 2.D0**(-26)
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E2(I-1) = E2(I)
C
      F = 0.0D0
      B = 0.0D0
      C = 0.0D0
      E2(N) = 0.0D0
C
      DO 290 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DSQRT(E2(L)))
         IF (B .GT. H) GO TO 105
         B = H
         C = B * B
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
  105    DO 110 M = L, N
            IF (E2(M) .LE. C) GO TO 120
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
         WRITE(6,*)' **** FATAL ERROR IN TQLRAT **** '
         WRITE(6,*)' **** FALLEN THROUGH BOTTOM OF LOOP 110 *** '
         STOP
C
  120    IF (M .EQ. L) GO TO 210
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         S = DSQRT(E2(L))
         G = D(L)
         P = (D(L1) - G) / (2.0D0 * S)
         R = DSQRT(P*P+1.0D0)
         D(L) = S / (P + DSIGN(R,P))
         H = G - D(L)
C
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** RATIONAL QL TRANSFORMATION **********
         G = D(M)
         IF (G .EQ. 0.0D0) G = B
         H = G
         S = 0.0D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            P = G * H
            R = P + E2(I)
            E2(I+1) = S * R
            S = E2(I) / R
            D(I+1) = H + S * (H + D(I))
            G = D(I) - E2(I) / G
            IF (G .EQ. 0.0D0) G = B
            H = G * P / R
  200    CONTINUE
C
         E2(L) = S * G
         D(L) = H
C     ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST **********
         IF (H .EQ. 0.0D0) GO TO 210
         IF (DABS(E2(L)) .LE.DABS(C/H)) GO TO 210
         E2(L) = H * E2(L)
         IF (E2(L) .NE. 0.0D0) GO TO 130
  210    P = D(L) + F
C     ********** ORDER EIGENVALUES **********
         IF (L .EQ. 1) GO TO 250
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- *********
         DO 230 II = 2, L
            I = L + 2 - II
            IF (P .GE. D(I-1)) GO TO 270
            D(I) = D(I-1)
  230    CONTINUE
C
  250    I = 1
  270    D(I) = P
  290 CONTINUE
C
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQLRAT **********
      END
C
C
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION D(N),E(N),Z(NM,N)
      REAL*8 MACHEP
C     **************************************************************
C     THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2,
C     NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND
C     WILKINSON.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971).
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
C     OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD.
C     THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO
C     BE FOUND IF  TRED2  HAS BEEN USED TO REDUCE THIS
C     FULL MATRIX TO TRIDIAGONAL FORM.
C
C     ON INPUT :
C
C        NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
C          ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
C          DIMENSION STATEMENT,
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C          IN ITS LAST N-1 POSITIONS.  E(1) IS ARBITRARY
C
C        Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE
C          REDUCTION BY  TRED2, IF PERFORMED.  IF THE EIGENVECTORS
C          OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN
C          THE IDENTITY MATRIX.
C
C      ON OUTPUT :
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT
C          UNORDERED FOR INDICES 1,2,...,IERR-1,
C
C        E HAS BEEN DESTROYED,
C
C        Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC
C          TRIDIAGONAL (OR FULL) MATRIX.  IF AN ERROR EXIT IS MADE,
C          Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED
C          EIGENVALUES,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C     ***************************************************************
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.

      MACHEP = 2.D0**(-26)
C
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
  100 E(I-1) = E(I)
C
      F = 0.0D0
      B = 0.0D0
      E(N) = 0.0D0
C
      DO 240 L = 1, N
         J = 0
         H = MACHEP * (DABS(D(L)) + DABS(E(L)))
         IF (B .LT. H) B = H
C     ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT **********
         DO 110 M = L, N
            IF (DABS(E(M)) .LE. B) GO TO 120
C     ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
  110    CONTINUE
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
C     ********** FORM SHIFT **********
         L1 = L + 1
         G = D(L)
         P = (D(L1) - G) / (2.0D0 * E(L))
         R = DSQRT(P*P+1.0D0)
         D(L) = E(L) / (P + DSIGN(R,P))
         H = G - D(L)
         DO 140 I = L1, N
  140    D(I) = D(I) - H
C
         F = F + H
C     ********** QL TRANSFORMATION **********
         P = D(M)
         C = 1.0D0
         S = 0.0D0
         MML = M - L
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
         DO 200 II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (DABS(P) .LT. DABS(E(I))) GO TO 150
            C = E(I) / P
            R = DSQRT(C*C+1.0D0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0D0 / R
            GO TO 160
  150       C = P / E(I)
            R = DSQRT(C*C+1.0D0)
            E(I+1) = S * E(I) * R
            S = 1.0D0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
C     ********** FORM VECTOR **********
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
  200    CONTINUE
         E(L) = S * P
         D(L) = C * P
         IF (DABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
C     ********** ORDER EIGENVALUES AND EIGENVECTORS **********
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
C
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
C
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
  300 CONTINUE
      GO TO 1001
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
 1000 IERR = L
 1001 RETURN
C     ********** LAST CARD OF TQL2 **********
      END


      SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine whether or not a given polynomial P(x) with real
C     coefficients is stable, either in the continuous-time or discrete-
C     time case.
C
C     A polynomial is said to be stable in the continuous-time case
C     if all its zeros lie in the left half-plane, and stable in the
C     discrete-time case if all its zeros lie inside the unit circle.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Indicates whether the stability test to be applied to
C             P(x) is in the continuous-time or discrete-time case as
C             follows:
C             = 'C':  Continuous-time case;
C             = 'D':  Discrete-time case.
C
C     Input/Output Parameters
C
C     DP      (input/output) INTEGER
C             On entry, the degree of the polynomial P(x).  DP >= 0.
C             On exit, if P(DP+1) = 0.0 on entry, then DP contains the
C             index of the highest power of x for which P(DP+1) <> 0.0.
C
C     P       (input) DOUBLE PRECISION array, dimension (DP+1)
C             This array must contain the coefficients of P(x) in
C             increasing powers of x.
C
C     STABLE  (output) LOGICAL
C             Contains the value .TRUE. if P(x) is stable and the value
C             .FALSE. otherwise (see also NUMERICAL ASPECTS).
C
C     NZ      (output) INTEGER
C             If INFO = 0, contains the number of unstable zeros - that
C             is, the number of zeros of P(x) in the right half-plane if
C             DICO = 'C' or the number of zeros of P(x) outside the unit
C             circle if DICO = 'D' (see also NUMERICAL ASPECTS).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (2*DP+2)
C             The leading (DP+1) elements of DWORK contain the Routh
C             coefficients, if DICO = 'C', or the constant terms of
C             the Schur-Cohn transforms, if DICO = 'D'.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = k:  if the degree of the polynomial P(x) has been
C                   reduced to (DB - k) because P(DB+1-j) = 0.0 on entry
C                   for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if on entry, P(x) is the zero polynomial;
C             = 2:  if the polynomial P(x) is most probably unstable,
C                   although it may be stable with one or more zeros
C                   very close to either the imaginary axis if
C                   DICO = 'C' or the unit circle if DICO = 'D'.
C                   The number of unstable zeros (NZ) is not determined.
C
C     METHOD
C
C     The stability of the real polynomial
C                                         2                DP
C        P(x) = p(0) + p(1) * x + p(2) * x  + ... + p(DP) x
C
C     is determined as follows.
C
C     In the continuous-time case (DICO = 'C') the Routh algorithm
C     (see [1]) is used. The routine computes the Routh coefficients and
C     if they are non-zero then the number of sign changes in the
C     sequence of the coefficients is equal to the number of zeros with
C     positive imaginary part.
C
C     In the discrete-time case (DICO = 'D') the Schur-Cohn
C     algorithm (see [2] and [3]) is applied to the reciprocal
C     polynomial
C                                                2               DP
C        Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x  + ... + p(0) x  .
C
C     The routine computes the constant terms of the Schur transforms
C     and if all of them are non-zero then the number of zeros of P(x)
C     with modulus greater than unity is obtained from the sequence of
C     constant terms.
C
C     REFERENCES
C
C     [1] Gantmacher, F.R.
C         Applications of the Theory of Matrices.
C         Interscience Publishers, New York, 1959.
C
C     [2] Kucera, V.
C         Discrete Linear Control. The Algorithmic Approach.
C         John Wiley & Sons, Chichester, 1979.
C
C     [3] Henrici, P.
C         Applied and Computational Complex Analysis (Vol. 1).
C         John Wiley & Sons, New York, 1974.
C
C     NUMERICAL ASPECTS
C
C     The algorithm used by the routine is numerically stable.
C
C     Note that if some of the Routh coefficients (DICO = 'C') or
C     some of the constant terms of the Schur-Cohn transforms (DICO =
C     'D') are small relative to EPS (the machine precision), then
C     the number of unstable zeros (and hence the value of STABLE) may
C     be incorrect.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01HD by F. Delebecque and
C     A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations,
C     stability, stability criteria, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      LOGICAL           STABLE
      INTEGER           DP, INFO, IWARN, NZ
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), P(*)
C     .. Local Scalars ..
      LOGICAL           DICOC
      INTEGER           I, K, K1, K2, SIGNUM
      DOUBLE PRECISION  ALPHA, P1, PK1
C     .. External Functions ..
      INTEGER           IDAMAX
      LOGICAL           LSAME
      EXTERNAL          IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DRSCL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         SIGN
C     .. Executable Statements ..
C
      IWARN = 0
      INFO  = 0
      DICOC = LSAME( DICO, 'C' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN
         INFO = -1
      ELSE IF( DP.LT.0 ) THEN
         INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC01TD', -INFO )
         RETURN
      END IF
C
C     WHILE (DP >= 0 and P(DP+1) = 0 ) DO
   20 IF ( DP.GE.0 ) THEN
         IF ( P(DP+1).EQ.ZERO ) THEN
            DP = DP - 1
            IWARN = IWARN + 1
            GO TO 20
         END IF
      END IF
C     END WHILE 20
C
      IF ( DP.EQ.-1 ) THEN
         INFO = 1
         RETURN
      END IF
C
C     P(x) is not the zero polynomial and its degree is exactly DP.
C
      IF ( DICOC ) THEN
C
C        Continuous-time case.
C
C        Compute the Routh coefficients and the number of sign changes.
C
         CALL DCOPY( DP+1, P, 1, DWORK, 1 )
         NZ = 0
         K = DP
C        WHILE ( K > 0 and DWORK(K) non-zero) DO
   40    IF ( K.GT.0 ) THEN
            IF ( DWORK(K).EQ.ZERO ) THEN
               INFO = 2
            ELSE
               ALPHA = DWORK(K+1)/DWORK(K)
               IF ( ALPHA.LT.ZERO ) NZ = NZ + 1
               K = K - 1
C
               DO 60 I = K, 2, -2
                  DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1)
   60          CONTINUE
C
               GO TO 40
            END IF
         END IF
C        END WHILE 40
      ELSE
C
C        Discrete-time case.
C
C        To apply [3], section 6.8, on the reciprocal of polynomial
C        P(x) the elements of the array P are copied in DWORK in
C        reverse order.
C
         CALL DCOPY( DP+1, P, 1, DWORK, -1 )
C                                                           K-1
C        DWORK(K),...,DWORK(DP+1), are the coefficients of T   P(x)
C        scaled with a factor alpha(K) in order to avoid over- or
C        underflow,
C                                                    i-1
C        DWORK(i), i = 1,...,K, contains alpha(i) * T   P(0).
C
         SIGNUM = ONE
         NZ = 0
         K  = 1
C        WHILE ( K <= DP and DWORK(K) non-zero ) DO
   80    IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN
C                                        K
C           Compute the coefficients of T P(x).
C
            K1 = DP - K + 2
            K2 = DP + 2
            ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 ))
            IF ( ALPHA.EQ.ZERO ) THEN
               INFO = 2
            ELSE
               CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 )
               CALL DRSCL( K1, ALPHA, DWORK(K2), 1 )
               P1  = DWORK(K2)
               PK1 = DWORK(K2+K1-1)
C
               DO 100 I = 1, K1 - 1
                  DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I)
  100          CONTINUE
C
C              Compute the number of unstable zeros.
C
               K = K + 1
               IF ( DWORK(K).EQ.ZERO ) THEN
                  INFO = 2
               ELSE
                  SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) )
                  IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1
               END IF
               GO TO 80
            END IF
C           END WHILE 80
         END IF
      END IF
C
      IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN
         STABLE = .TRUE.
      ELSE
         STABLE = .FALSE.
      END IF
C
      RETURN
C *** Last line of MC01TD ***
      END


if ( a .gt. 20.0 ) then
   q = q + a**2
else if ( a .ge. 0.0 ) then
   q = q + 2*a**3
else
   q = q - a
end if


module routines
implicit none
contains

subroutine f_routine(m, fnumber)
   integer, intent(in) :: m
   integer(kind=16), intent(out) :: fnumber
   integer(kind=16), dimension(2) :: last_two
   integer :: i

   last_two = (/ 1, 1 /)
   do i = 0, m
      if ((i .eq. 0) .or. (i .eq. 1)) then
         fnumber = 1
      else
         fnumber = last_two(1) + last_two(2)
         if (mod(i,2) .eq. 0) then
            last_two(1) = fnumber
         else if (mod(i,2) .ne. 0) then
            last_two(2) = fnumber
         end if
      end if
   end do

end subroutine f_routine

end module routines


    MODULE random_gamma_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_gamma(scale,shape)
! .. Use Statements ..
        USE random_standard_gamma_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_gamma
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: scale
        REAL :: shape
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION RANDOM_GAMMA( scale, shape )
!           GENerates random deviates from GAMma distribution
!                              Function
!     Generates random deviates from the gamma distribution whose
!     density is
!          (scale**shape)/Gamma(shape) * X**(shape-1) * Exp(-scale*X)
!                              Arguments
!     JJV added the argument ranges supported
!     scale --> Location parameter of Gamma distribution
!                              REAL scale ( scale > 0 )
!     shape --> Shape parameter of Gamma distribution
!                              REAL shape ( shape > 0 )
!                              Method
!     Renames SGAMMA from TOMS as slightly modified by BWB to use RANF
!     instead of SUNIF.
!     For details see:
!               (Case shape >= 1.0)
!               Ahrens, J.H. and Dieter, U.
!               Generating Gamma Variates by scale
!               Modified Rejection Technique.
!               Comm. ACM, 25,1 (Jan. 1982), 47 - 54.
!     Algorithm GD
!     JJV altered the following to reflect random_standard_gamma argument ranges
!               (Case 0.0 < shape < 1.0)
!               Ahrens, J.H. and Dieter, U.
!               Computer Methods for Sampling from Gamma,
!               Beta, Poisson and Binomial Distributions.
!               Computing, 12 (1974), 223-246/
!     Adapted algorithm GS.
!**********************************************************************
!     JJV added argument value checker
        IF (scale<=0.0 .OR. shape<=0.0) THEN
          WRITE (*,*) 'In RANDOM_GAMMA - Either (1) Location &
            &param scale <= 0.0 or'
          WRITE (*,*) '(2) Shape param shape <= 0.0 - ABORT!'
          WRITE (*,*) 'scale value: ', scale, 'shape value: ', shape
          STOP 'Location or shape param out of range in RANDOM_GAMMA &
            &- ABORT!'
        END IF
!     JJV end addition

        random_gamma = random_standard_gamma(shape)/scale
!      random_gamma = random_gamma/scale
        RETURN

      END FUNCTION random_gamma

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

    END MODULE random_gamma_mod


module interpolate_module

  implicit none

  contains

      function interpolate(r, npts_model, model_r, model_var, iloc)

!     given the array of model coordinates (model_r), and variable (model_var),
!     find the value of model_var at point r using linear interpolation.
!     Eventually, we can do something fancier here.

      double precision, intent(in   ) :: r
      integer         , intent(in   ) :: npts_model
      double precision, intent(in   ) :: model_r(npts_model), model_var(npts_model)
      integer, intent(in), optional   :: iloc
      double precision                :: interpolate

      ! Local variables
      integer                         :: id
      double precision                :: slope,minvar,maxvar

!     find the location in the coordinate array where we want to interpolate
      if (present(iloc)) then
         id = iloc
      else
         id = locate(r, npts_model, model_r)
      end if

      if (id .eq. 1) then

         slope = (model_var(id+1) - model_var(id))/(model_r(id+1) - model_r(id))
         interpolate = slope*(r - model_r(id)) + model_var(id)

         ! safety check to make sure interpolate lies within the bounding points
         minvar = min(model_var(id+1),model_var(id))
         maxvar = max(model_var(id+1),model_var(id))
         interpolate = max(interpolate,minvar)
         interpolate = min(interpolate,maxvar)

      else if (id .eq. npts_model) then

         slope = (model_var(id) - model_var(id-1))/(model_r(id) - model_r(id-1))
         interpolate = slope*(r - model_r(id)) + model_var(id)

         ! safety check to make sure interpolate lies within the bounding points
         minvar = min(model_var(id),model_var(id-1))
         maxvar = max(model_var(id),model_var(id-1))
         interpolate = max(interpolate,minvar)
         interpolate = min(interpolate,maxvar)

      else

         if (r .ge. model_r(id)) then

            slope = (model_var(id+1) - model_var(id))/(model_r(id+1) - model_r(id))
            interpolate = slope*(r - model_r(id)) + model_var(id)

            ! ! safety check to make sure interpolate lies within the bounding points
            ! minvar = min(model_var(id+1),model_var(id))
            ! maxvar = max(model_var(id+1),model_var(id))
            ! interpolate = max(interpolate,minvar)
            ! interpolate = min(interpolate,maxvar)

         else

            slope = (model_var(id) - model_var(id-1))/(model_r(id) - model_r(id-1))
            interpolate = slope*(r - model_r(id)) + model_var(id)

            ! ! safety check to make sure interpolate lies within the bounding points
            ! minvar = min(model_var(id),model_var(id-1))
            ! maxvar = max(model_var(id),model_var(id-1))
            ! interpolate = max(interpolate,minvar)
            ! interpolate = min(interpolate,maxvar)

          end if

      endif

    end function interpolate

    subroutine tri_interpolate(x, y, z, npts_x, npts_y, npts_z, &
                               model_x, model_y, model_z, model_var, &
                               interp_var, derivs, error)

      use amrex_constants_module, only: ONE

      ! tri-linear interpolation; useful for EOS tables
      ! this is stricly interpolation, so if the point (x,y,z) is outside
      ! the bounds of model_x,model_y,model_z, then we abort
      double precision, intent(in   ) :: x,y,z
      integer,          intent(in   ) :: npts_x, npts_y, npts_z
      double precision, intent(in   ) :: model_x(npts_x), &
                                         model_y(npts_y), &
                                         model_z(npts_z), &
                                         model_var(npts_x,npts_y,npts_z)
      double precision, intent(  out) :: interp_var, derivs(3)
      logical,          intent(  out) :: error

      integer :: ix,iy,iz
      double precision :: deltax, deltay, deltaz
      double precision :: c(8), delta(8)

      error = .false.

      ! find the indices below the point (x,y,z)
      do ix = 2, npts_x
         if (model_x(ix) .ge. x) exit
      enddo
      do iy = 2, npts_y
         if (model_y(iy) .ge. y) exit
      enddo
      do iz = 2, npts_z
         if (model_z(iz) .ge. z) exit
      enddo
      if ((ix>npts_x) .or. (iy>npts_y) .or. (iz>npts_z)) then !&
         error = .true.
         return
      endif

      ix=ix-1
      iy=iy-1
      iz=iz-1

      ! form the weights for each point
      deltax = (x - model_x(ix))/(model_x(ix+1)-model_x(ix))
      deltay = (y - model_y(iy))/(model_y(iy+1)-model_y(iy))
      deltaz = (z - model_z(iz))/(model_z(iz+1)-model_z(iz))
      delta = (/ ONE, deltax, deltay, deltaz, &
                 deltax*deltay, deltax*deltaz, deltay*deltaz, &
                 deltax*deltay*deltaz /)

      ! the model_var function values for Lagrange interpolation
      c(1) = model_var(ix  ,iy  ,iz  )
      c(2) = model_var(ix+1,iy  ,iz  ) - model_var(ix  ,iy  ,iz  )
      c(3) = model_var(ix  ,iy+1,iz  ) - model_var(ix  ,iy  ,iz  )
      c(4) = model_var(ix  ,iy  ,iz+1) - model_var(ix  ,iy  ,iz  )
      c(5) = model_var(ix+1,iy+1,iz  ) - model_var(ix  ,iy+1,iz  ) + &
             model_var(ix  ,iy  ,iz  ) - model_var(ix+1,iy  ,iz  )
      c(6) = model_var(ix+1,iy  ,iz+1) - model_var(ix  ,iy  ,iz+1) + &
             model_var(ix  ,iy  ,iz  ) - model_var(ix+1,iy  ,iz  )
      c(7) = model_var(ix  ,iy+1,iz+1) - model_var(ix  ,iy  ,iz+1) + &
             model_var(ix  ,iy  ,iz  ) - model_var(ix  ,iy+1,iz  )
      c(8) = model_var(ix+1,iy+1,iz+1) - model_var(ix  ,iy+1,iz+1) + &
             model_var(ix  ,iy  ,iz+1) - model_var(ix+1,iy  ,iz+1) + &
             model_var(ix  ,iy+1,iz  ) - model_var(ix+1,iy+1,iz  ) + &
             model_var(ix+1,iy  ,iz  ) - model_var(ix  ,iy  ,iz  )

      ! interpolated value
      interp_var = sum(c*delta)
      ! derivs: dvar/dx, dvar/dy, dvar/dz
      derivs(1) = c(2) / (model_x(ix+1)-model_x(ix))
      derivs(2) = c(3) / (model_y(iy+1)-model_y(iy))
      derivs(3) = c(4) / (model_z(iz+1)-model_z(iz))

    end subroutine tri_interpolate

    function locate(x, n, xs)
      integer, intent(in) :: n
      double precision, intent(in) :: x, xs(n)
      integer :: locate

      integer :: ilo, ihi, imid

      if (x .le. xs(1)) then
         locate = 1
      else if (x .gt. xs(n-1)) then
         locate = n
      else

         ilo = 1
         ihi = n-1

         do while (ilo+1 .ne. ihi)
            imid = (ilo+ihi)/2
            if (x .le. xs(imid)) then
               ihi = imid
            else
               ilo = imid
            end if
         end do

         locate = ihi

      end if

    end function locate

end module interpolate_module


    MODULE random_uniform_integer_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_uniform_integer(low,high)
! .. Use Statements ..
        USE ecuyer_cote_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        INTEGER :: random_uniform_integer
! ..
! .. Parameters ..
        INTEGER, PARAMETER :: maxnum = 2147483561
        CHARACTER (20), PARAMETER :: err1 = 'LOW > HIGH in IGNUIN'
        CHARACTER (41), PARAMETER :: err2 = &
          ' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN'
! ..
! .. Scalar Arguments ..
        INTEGER, INTENT (IN) :: high, low
! ..
! .. Local Scalars ..
        INTEGER :: err, ign, maxnow, range, ranp1
! ..
! .. Intrinsic Functions ..
        INTRINSIC MOD
! ..
! .. Executable Statements ..

!**********************************************************************
!     INTEGER FUNCTION IGNUIN( LOW, HIGH )
!               GeNerate Uniform INteger
!                              Function
!     Generates an integer uniformly distributed between LOW and HIGH.
!                              Arguments
!     LOW --> Low bound (inclusive) on integer value to be generated
!                         INTEGER LOW
!     HIGH --> High bound (inclusive) on integer value to be generated
!                         INTEGER HIGH
!                              Note
!     If (HIGH-LOW) > 2,147,483,561 prints error message on * unit and
!     stops the program.
!**********************************************************************
!     random_large_integer generates integers between 1 and 2147483562
!     MAXNUM is 1 less than maximum generable value
        IF (low>high) THEN
          err = 1
!      ABORT-PROGRAM
        ELSE

          range = high - low
          IF (range>maxnum) THEN
            err = 2
!      ABORT-PROGRAM
          ELSE

            IF (low==high) THEN
              random_uniform_integer = low
              RETURN
            END IF

!     Number to be generated should be in range 0..RANGE
!     Set MAXNOW so that the number of integers in 0..MAXNOW is an
!     integral multiple of the number in 0..RANGE

            ranp1 = range + 1
            maxnow = (maxnum/ranp1)*ranp1
            ign = random_large_integer() - 1
            DO WHILE ( .NOT. ign<=maxnow)
              ign = random_large_integer() - 1
            END DO
            random_uniform_integer = low + MOD(ign,ranp1)
            RETURN

          END IF
        END IF
        IF (err==1) THEN
          WRITE (*,*) err1
        ELSE

!     TO ABORT-PROGRAM
          WRITE (*,*) err2
        END IF
        WRITE (*,*) ' LOW: ', low, ' HIGH: ', high
        WRITE (*,*) ' Abort on Fatal ERROR'
        IF (err==1) STOP 'LOW > HIGH in IGNUIN'

        STOP ' ( HIGH - LOW ) > 2,147,483,561 in IGNUIN'
      END FUNCTION random_uniform_integer

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

    END MODULE random_uniform_integer_mod


module covariance

use, intrinsic:: iso_c_binding, only: c_int
use comm,only: sp, dp
!use perf, only : sysclock2ms

implicit none (type, external)
private
public :: autocov_r, autocov_c

! interface autocov
! procedure autocov_r, autocov_c
! end interface autocov
!! disabled due to f2py incompatibility

contains

pure subroutine autocov_c(x, N, M, C) bind(c)
!! autocovariance estimate of 1-D vector (e.g. noisy sinusoid)
!!
!! input:
!! x is a 1-D vector
!! N is length of x
!! M is the size of signal block (integer)
!!
!! output:
!! C is the 2-D result

integer(c_int), intent(in) :: M,N
complex(dp), intent(in) :: x(N)
complex(dp), intent(out):: C(M,M)

integer(c_int) :: i
complex(dp) :: yn(M,1), R(M,M) !, work(M,M)

yn(:,1) = x(M:1:-1) ! index from M to 1, reverse order

R = matmul(yn, conjg(transpose(yn)))
!call zgemm('N','C',M,M,1,1._dp,yn,M,yn,M,0._dp,R,M) !slower, worse accuracy than matmul in Gfortran 5.2.1

do i = 2, N-M ! not concurrent
  yn(:,1) = x(M-1+i:i-1:-1)
  R = R + matmul(yn,conjg(transpose(yn)))
  !call zgemm('N','C',M,M,1,1._dp,yn,M,yn,M,0._dp,work,M)
  !R = R + work
enddo

C = R / real(N,dp)

end subroutine autocov_c

pure subroutine autocov_r(x,N,M,C) bind(c)
!! autocovariance estimate of 1-D vector (e.g. noisy sinusoid)
!!
!! input:
!! x is a 1-D vector
!! N is length of x
!! M is the size of signal block (integer)
!!
!! output:
!! C is the 2-D result

integer(c_int), intent(in) :: M,N
real(sp),intent(in) :: x(N)
real(sp),intent(out):: C(M,M)

integer(c_int) :: i
real(sp) :: yn(M,1), R(M,M) !, work(M,M)

yn(:,1) = x(M:1:-1) ! index from M to 1, reverse order

R = matmul(yn, transpose(yn))

do i = 2, N-M ! not concurrent
  yn(:,1) = x(M-1+i:i-1:-1)
  R = R + matmul(yn, transpose(yn))
enddo

C = R / real(N, sp)

end subroutine autocov_r

end module covariance


subroutine medianbinning2d(n,nx,ny,x0,dx,y0,dy,x,y,z,npb,binmed,info)
  implicit none
  ! arguments
  integer, intent(in) :: n, nx, ny
  real, intent(in) :: x0, dx, y0, dy, x(n), y(n), z(n)
  integer, intent(out) :: npb(nx,ny), info
  real, intent(out) :: binmed(nx,ny)
  ! local variables
  real :: zcopy(n)
  integer :: ixybin(n), ixbin(n), iybin(n), ord(n)
  integer :: i, j, k, i0, i1
  integer :: ix, iy, iz, ixy
  integer :: nrun

  ! initialise the output arrays
  info = 0
  npb = 0
  binmed = -999.0

  ! make a local copy
  do i=1,n
    zcopy(i) = z(i)
  end do

  ! assign each value a bin
  do i=1,n
    ! assume regularly spaced bins
    ix = int((x(i) - x0)/dx) + 1
    iy = int((y(i) - y0)/dy) + 1
    ! range check: ix
    if((ix .le. 0) .or. (ix .gt. nx)) then
      write(*,*) 'ix',ix,'out of bounds...'
      info = -1
      return
    end if
    ! range check: iy
    if((iy .le. 0) .or. (iy .gt. ny)) then
      write(*,*) 'iy',iy,'out of bounds...'
      info = -2
      return
    end if
    ! a single index that combines both bin indices
    ixy = (ix-1)*ny + iy
    !
    ixbin(i) = ix
    iybin(i) = iy
    ixybin(i) = ixy
  end do
  ! group together all values for individual bins
  call qsort_int(ixybin,ord,n)
  ! sort the indices and the values
  ixybin = ixybin(ord)
  ixbin = ixbin(ord)
  iybin = iybin(ord)
  zcopy  = zcopy(ord)
  !
  i1 = 0
  do while(i1 .lt. n)
    ! find the values within this bin
    i0 = i1 + 1
    i1 = i0
    do j=i0+1,n
      if(ixybin(i0) .ne. ixybin(j)) then
        i1 = j-1
        exit
      end if
    end do

    ! see how many there are
    nrun = i1 - i0 + 1
    ! store the number of values
    npb(ixbin(i0), iybin(i0)) = nrun
    ! calculate the median
    binmed(ixbin(i0), iybin(i0)) = median(zcopy(i0:i1),nrun)
  end do

  Return
End Subroutine Medianbinning2d

function median(x,n) result(med)
  implicit none
  ! arguments
  integer, intent(in)  :: n
  real,    intent(in)  :: x(n)
  real                 :: med
  ! local variables
  integer :: ord(n)
  integer :: k

  ! easy cases:
  if(n .eq. 1) then
     med = x(1)
  else if(n .eq. 2) then
     med = (x(1) + x(2)) * 0.5
  else
     ! standard case (need to sort)

     ! sort this list of values
     call qsort_real(x, ord, n)
     ! two cases for the median
     if(mod(n,2) .eq. 0) then
        ! even cases: take the mean of the two middle values
        k =  n/2
        med = (x(ord(k)) + x(ord(k+1)))*0.5
     else
        ! odd cases: take the sole middle value
        k = (n+1)/2
        med = x(ord(k))
     end if
  end if

  return
end function median


!> This module containes linear algebra subroutines
!! such as matrix diagonalization and inversion
MODULE linear_algebra
    USE kinds
    IMPLICIT NONE

CONTAINS

    !> Diagonalized a real symmetric matrix and returns the eigenvalues and the
    !! eigenvectors associated with that matrix
    SUBROUTINE diagonalize_real_symmetric( eigenvectors, eigenvalues )
        USE kinds
        IMPLICIT NONE
        REAL(dp), INTENT(out) :: eigenvalues( : )
        REAL(dp), INTENT(inout) :: eigenvectors( : , : )
        REAL(dp), ALLOCATABLE :: work( : )
        INTEGER :: info, lwork
        CHARACTER(1) :: jobz='V', uplo='U'
        lwork = 3 * SIZE(eigenvalues) - 1

        IF ( ALLOCATED( work ) .EQV. .TRUE. ) THEN
            DEALLOCATE( work )
        END IF
        ALLOCATE( work(lwork) )

        CALL dsyev( jobz, uplo, SIZE(eigenvalues), eigenvectors,&
                SIZE(eigenvalues), eigenvalues, work, lwork, info)

        IF ( ALLOCATED(work) .EQV. .TRUE. ) THEN
            DEALLOCATE( work )
        END IF

    END SUBROUTINE diagonalize_real_symmetric

    !> Function to perform the trace of a real square matrix
    FUNCTION trace_real_matrix( matrix ) RESULT( res )
        USE kinds
        IMPLICIT NONE
        REAL(dp) :: matrix(:,:), res
        INTEGER :: i
        res = 0.0_dp
        IF ( SIZE( matrix( : ,1 ) ) /= SIZE( matrix( 1 ,: ) ) ) THEN
            WRITE(*,*) 'matrix sent to trace function is not square'
            STOP 1
        END IF

        DO i = 1 , SIZE( matrix(:,1) )
            res = res + matrix(i,i)
        END DO

    END FUNCTION trace_real_matrix

    !> Function to perform the trace of a real square matrix
    FUNCTION trace_complex_matrix( matrix ) RESULT( res )
        USE kinds
        IMPLICIT NONE
        COMPLEX(dp) :: matrix(:,:), res
        INTEGER :: i
        res = 0.0_dp
        IF ( SIZE( matrix( : ,1 ) ) /= SIZE( matrix( 1 ,: ) ) ) THEN
            WRITE(*,*) 'matrix sent to trace function is not square'
            STOP 1
        END IF

        DO i = 1 , SIZE( matrix(:,1) )
            res = res + matrix(i,i)
        END DO

    END FUNCTION trace_complex_matrix

END MODULE linear_algebra


      subroutine lagrange(x, xi, yi, ans)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

!  Lagrange interpolation - Polynomial interpolation at point x
!  xi(1) <= x <= xi(4).  Yi(n) is the functional value at XI(n).

      implicit none

      real*8 :: x, xi(4), yi(4), ans
      real*8 :: fm1, fm2, fm3, fm4

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

      fm1 = x - XI(1)
      fm2 = x - XI(2)
      fm3 = x - XI(3)
      fm4 = x - XI(4)

!  Get the "answer" at the requested X

      ans = fm2*fm3*fm4*YI(1)/                                         &
                      ((XI(1)-XI(2))*(XI(1)-XI(3))*(XI(1)-XI(4)))  +   &
            fm1*fm3*fm4*YI(2)/                                         &
                      ((XI(2)-XI(1))*(XI(2)-XI(3))*(XI(2)-XI(4)))  +   &
            fm1*fm2*fm4*YI(3)/                                         &
                      ((XI(3)-XI(1))*(XI(3)-XI(2))*(XI(3)-XI(4)))  +   &
            fm1*fm2*fm3*YI(4)/                                         &
                      ((XI(4)-XI(1))*(XI(4)-XI(2))*(XI(4)-XI(3)))

      return
      end subroutine lagrange


!
! Project Euler Problem 1: Multiples of 3 and 5
!
! D. C. Groothuizen Dijkema - November, 2019
!

subroutine run
  implicit none
  integer :: itr,sum

  sum=0

  do itr=1,999
    if(mod(itr,3).eq.0 .or. mod(itr,5).eq.0) then
      sum=sum+itr
    end if
  end do

  print *,"The sum of all multiples of 3 and 5 less than 1000 is:",sum

end subroutine run

program multiples
  implicit none
  integer :: beginning,end,rate

  call system_clock(beginning,rate)
  call run
  call system_clock(end)
  print *,"Elapsed time:",real(end-beginning)/real(rate)

end program


C$Procedure      UNORM ( Unit vector and norm, 3 dimensional )

      SUBROUTINE UNORM ( V1, VOUT, VMAG )

C$ Abstract
C
C     Normalize a double precision 3-vector and return its magnitude.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION  V1   ( 3 )
      DOUBLE PRECISION  VOUT ( 3 )
      DOUBLE PRECISION  VMAG

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     V1         I   Vector to be normalized.
C     VOUT       O   Unit vector V1 / |V1|.
C                    If V1 is the zero vector, then VOUT will also
C                    be zero.
C     VMAG       O   Magnitude of V1, i.e. |V1|.
C
C$ Detailed_Input
C
C     V1      This variable may contain any 3-vector, including the
C             zero vector.
C
C$ Detailed_Output
C
C     VOUT    This variable contains the unit vector in the direction
C             of V1.  If V1 is the zero vector, then VOUT will also be
C             the zero vector.
C
C     VMAG    This is the magnitude of V1.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     UNORM references a function called VNORM (which itself is
C     numerically stable) to calculate the norm of the input vector V1.
C     If the norm is equal to zero, then each component of the output
C     vector VOUT is set to zero.  Otherwise, VOUT is calculated by
C     dividing V1 by the norm.
C
C$ Examples
C
C     The following table shows how selected V1 implies VOUT and MAG.
C
C        V1                    VOUT                   MAG
C        ------------------    ------------------     ----
C        (5, 12, 0)            (5/13, 12/13, 0)       13
C        (1D-7, 2D-7, 2D-7)    (1/3, 2/3, 2/3)        3D-7
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.M. Owen       (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 23-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     3-dimensional unit vector and norm
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 10-JAN-1989 (WLT)
C
C     Error free specification added.
C
C-&
C

C
C     SPICELIB functions
C
      DOUBLE PRECISION   VNORM

C
C  Obtain the magnitude of V1
C
      VMAG = VNORM(V1)
C
C   If VMAG is nonzero, then normalize.  Note that this process is
C   numerically stable: overflow could only happen if VMAG were small,
C   but this could only happen if each component of V1 were small.
C   In fact, the magnitude of any vector is never less than the
C   magnitude of any component.
C
      IF ( VMAG .GT. 0.D0 ) THEN
         VOUT(1) = V1(1) / VMAG
         VOUT(2) = V1(2) / VMAG
         VOUT(3) = V1(3) / VMAG
      ELSE
         VOUT(1) = 0.D0
         VOUT(2) = 0.D0
         VOUT(3) = 0.D0
      END IF

      RETURN
      END


! { dg-do "run" }
!
! Example from F2003, sec 13.7.125
!
  INTEGER, PARAMETER :: m(3,3) = RESHAPE ([1,0,0,0,1,0,0,0,1], [3,3])
  INTEGER, PARAMETER :: v(3)   = [1,2,3]
  LOGICAL, PARAMETER :: F = .FALSE., T = .TRUE.
  LOGICAL, PARAMETER :: q(3,3) = RESHAPE ([F,T,F,T,F,F,F,F,T], [3,3])

  INTEGER, PARAMETER :: r1(3,3) = UNPACK (V, MASK=Q, FIELD=M)
  INTEGER, PARAMETER :: r2(3,3) = UNPACK (V, MASK=Q, FIELD=0)

  IF (ANY (r1 /= RESHAPE ([1,1,0,2,1,0,0,0,3], [3,3]))) CALL ABORT()
  IF (ANY (r2 /= RESHAPE ([0,1,0,2,0,0,0,0,3], [3,3]))) CALL ABORT()
END


PROGRAM q2
    IMPLICIT NONE
    REAL, PARAMETER:: PI = acos(-1.0)
    REAL:: a, b, xmin, xmax, dx
    REAL:: x(500), J(500, 0:2)
    INTEGER::  N, m, i    ! N is number of segment
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of segment: "
    READ(*, *) N

    a = 0
    b = PI

    xmin = 0
    xmax = 20
    dx = (xmax-xmin)/(500-1)
    DO m = 0, 2
        DO i = 1, 500
            x(i) = xmin + (i-1) * dx
            CALL SimpsonsRule(a, b, J(i, m), N, m, x(i))
        ENDDO
    ENDDO

    OPEN(UNIT = 20, FILE = 'output.txt')
        DO i = 1, 500
            WRITE(20, *) x(i), (1./PI) * J(i, 0), (1./PI) * J(i, 1), (1./PI) * J(i, 2)
        ENDDO
    CLOSE(20)

    CONTAINS
    SUBROUTINE SimpsonsRule(a, b, Area, N, m, x)
        IMPLICIT NONE
        REAL:: a, b, Area, h, x
        INTEGER:: N, i, m
        ! N is number of segment
        IF(N .LT. 2) THEN
            Area = 0.0
            RETURN
        ENDIF

        h = (b-a)/N
        Area = f(m, a, x) + f(m, b, x)
        DO i = 1, N/2
            Area = Area + 4 * f(m, a + (2*i - 1) * h, x)
        ENDDO
        DO i = 1, (N+1)/2 - 1
            Area = Area + 2 * f(m, a + 2 * i * h, x)
        ENDDO
        Area = (h/3) * Area
    END SUBROUTINE SimpsonsRule

    REAL FUNCTION f(m, theta, x)
        IMPLICIT NONE
        REAL:: x, theta
        INTEGER:: m
        f = Cos(m * theta - x * sin(theta))
        RETURN
    END FUNCTION f

END PROGRAM q2