module mymodule

use omp_lib

contains

function eikR(a,k,n) result(M)
    implicit none

    integer,            intent(in)  :: n
    real(kind=8),       intent(in)  :: a(n)
    complex(kind=8),    intent(in)  :: k
    complex(kind=8)  :: M(n,n)

    ! Local
    integer                         :: i, j
    real(kind=8)  :: rtmp(n), sinp(n), cosp(n), tmp_exp(n)
    real(kind=8)  :: itmp(n), a_pow_2(n)

    complex(kind=8) :: imk
    real(kind=8) :: rimk
    real(kind=8) :: iimk, tmp

    imk = (0,1) * k
    rimk = real(imk)
    iimk = imag(imk)

    a_pow_2 = a * a

    !$OMP PARALLEL DO DEFAULT(private) SHARED(a_pow_2, M, n, rimk,iimk)
    do j=1,n

    rtmp = a_pow_2 + a_pow_2(j)
    call vdsqrt(n, rtmp, rtmp)

    ! real part
    call vdexp(n, rimk * rtmp, tmp_exp)

    ! imag part
    call vdsincos(n, iimk * rtmp, sinp, cosp)

    ! assemble output
    M(:, j) = cmplx(tmp_exp * cosp, tmp_exp * sinp)
    end do
    !$OMP END PARALLEL DO

end function eikR

function eikR_orig(a,k,n) result(M)
    implicit none

    integer,            intent(in)  :: n
    real(kind=8),       intent(in)  :: a(n)
    complex(kind=8),    intent(in)  :: k
    complex(kind=8)                 :: M(n,n)

    ! Local
    integer                         :: i, j

    !$OMP PARALLEL DO PRIVATE(J)
    do j=1,n
    do i=1,n

        M(i,j) = exp((0,1)*k*sqrt(a(i)**2 + a(j)**2))

    end do
    end do
    !$OMP END PARALLEL DO

end function eikR_orig

end module


SUBROUTINE GammaFunctions(x,n,dir,ftype,gam,param)
!
! Gamma functions for relaxation.
! HBB: added several other options. 3/2019
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER::n, ftype
REAL(KIND=long), DIMENSION(n) :: x, gam, tmp
REAL(KIND=long) :: param
INTEGER :: dir
IF (n>1) THEN
	tmp = (x - x(1))/(x(n)-x(1))
ELSE
	tmp = x
ENDIF
SELECT CASE (ABS(ftype))
	CASE (9) ! Allan's sponge filter: 1->0
		gam = one - tmp**param
	CASE (10) ! third order poly. with clamped BCs: 0->1
		gam = three*tmp**2-two*tmp**3
        CASE (11) ! exponential: 0->1
                gam=(exp(tmp**param)-1)/(exp(one)-one)
        CASE (12) ! gamma function, x0=x(n): 0->1
                gam=exp(-((x-x(n))/(x(n)-x(1)))**2/(2*param**2))
        CASE (13) ! 1-gamma function, x0=x(n): 1->0
                gam=1-exp(-((x-x(n))/(x(n)-x(1)))**2/(2*param**2))
        CASE (14) ! exponential: 1->0
                gam=1-(exp(tmp**param)-1)/(exp(one)-one)
END SELECT
IF (dir==-1) THEN ! REVERSE
	gam = gam(n:1:-1)  ! FIXME: not just for x
ENDIF
END SUBROUTINE GammaFunctions


function fahrenheit_to_celsius(temp_f) result(temp_c)
implicit none
real temp_f
real temp_c
temp_c = (temp_f - 32.0) * (5.0/9.0)
end function fahrenheit_to_celsius

temp_c = fahrenheit_to_celsius(100.0)
write(*,*) temp_c


c=======================================================================
c
c     subroutine PEARCH
c
c     Autoregressive Conditionally Heteroskedastic (ARCH) process generator
c
c       e(t) = sigma(t)*u(t)
c
c       where
c
c       sigma(t) = sqrt[w + alpha(1)*e(t-1)^2 + ... + alpha(p)*e(t-p)^2]
c
c-----------------------------------------------------------------------
      SUBROUTINE pearch ( T, N, P, w, alpha, y, sigma, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            P      : process order (P > 0)                      integer
c            w      : constant parameter                          double
c            alpha  : ARCH parameter, vector (P)                  double
c
c     OUTPUT :
c            y      : generated process (N)                       double
c            sigma  : generated conditional variance (N)          double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER N, T, P, info
      DOUBLE PRECISION w, alpha(*), y(*), sigma(*)
c
c     local variables
      INTEGER i, j, k
      DOUBLE PRECISION sum
c
c     external functions
      DOUBLE PRECISION rn
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     test time
      IF (T .LT. 0) RETURN
c
c     test if P < 0 or P > N
      IF ((P .LT. 1).OR.(P .GT. N)) THEN
        info = -3101
        RETURN
      ENDIF
c
c     initialization step
      sum = 0.
      DO j = 1,P
        sum = sum + alpha(j)
      ENDDO
c
c     test if sum(alpha) < 1.
      IF (sum .GE. 1.) THEN
        info = -3102
        RETURN
      ENDIF
c
c     initialization of initial value(s)
c     y(1),...,y(p) and volatility
      DO i = 1,P
        sigma(i) = sqrt(w/(1.-sum))
        y(i)     = sigma(i)*rn()
      ENDDO
c
c     loop
      DO i = 1,N-P
c
c        conditional volatility
         sum = w
         DO j = 1,P
            k = i + P - j
            sum = sum + alpha(j)*y(k)*y(k)
         ENDDO
         sigma(i + P) = sqrt(sum)
c
c        ARCH(P) process
         y(i + P) = sigma(i + P)*rn()
      ENDDO
c
      RETURN
      END


MODULE skew_symmetric

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

CONTAINS

SUBROUTINE trizd(n, a, e)

! ****

!  FUNCTION  -  REDUCES A REAL SKEW-SYMMETRIC MATRIX TO A SKEW-SYMMETRIC
!                 TRIDIAGONAL MATRIX USING ORTHOGONAL SIMILARITY
!                 TRANSFORMATIONS

!  PARAMETERS

!     N        - INPUT INTEGER SPECIFYING THE ORDER OF A

!     A(NA,N)  - ON INPUT, A CONTAINS THE REAL SKEW-SYMMETRIC MATRIX.
!                  ONLY THE STRICT LOWER TRIANGLE OF THE MATRIX NEED
!                  BE SUPPLIED.
!                ON OUTPUT, A CONTAINS INFORMATION ABOUT THE ORTHOGONAL
!                  TRANSFORMATIONS USED IN THE REDUCTION IN ITS FULL LOWER
!                  TRIANGLE.  THE STRICT UPPER TRIANGLE OF A IS UNALTERED.

!     E(N)     - OUTPUT ARRAY CONTAINING THE LOWER SUBDIAGONAL ELEMENTS
!                  OF THE TRIDIAGONAL MATRIX IN ITS LAST N-1 POSITIONS.
!                  E(1) IS SET TO ZERO.

!  REQUIRED FUNCTIONS - ABS,SIGN,SQRT

! ****

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: a(:,:)
REAL (dp), INTENT(OUT)  :: e(:)

REAL (dp)  :: f, g, h, scale
INTEGER    :: i, j, k, l, ii

IF (n /= 1) THEN

! *** MAIN DO LOOP  I=N STEP -1 UNTIL 2

  DO  ii = 2, n
    i = n + 2 - ii
    l = i - 1
    h = 0.
    scale = SUM( ABS(a(i,1:l)) )

! *** NORMALIZE ROW

    IF (scale == 0.) THEN
      e(i) = 0.
    ELSE

! *** COMPUTE ELEMENTS OF U VECTOR

      DO  k = 1, l
        a(i,k) = a(i,k) / scale
        h = h + a(i,k) * a(i,k)
      END DO

      f = a(i,l)
      g = -SIGN(SQRT(h),f)
      e(i) = scale * g
      h = h - f * g
      a(i,l) = f - g
      IF (l /= 1) THEN

! *** COMPUTE ELEMENTS OF A*U/H

        DO  j = 1, l
          g = DOT_PRODUCT( a(j,1:j-1), a(i,1:j-1) ) -  &
              DOT_PRODUCT( a(j+1:l,j), a(i,j+1:l) )

          e(j) = g / h
        END DO

! *** COMPUTE REDUCED A

        DO  j = 2, l
          f = a(i,j)
          g = e(j)

          DO  k = 1, j-1
            a(j,k) = a(j,k) + f * e(k) - g * a(i,k)
          END DO
        END DO
      END IF

      a(i,1:l) = scale * a(i,1:l)
    END IF

    a(i,i) = scale * SQRT(h)
  END DO
END IF

e(1) = 0.
RETURN
END SUBROUTINE trizd

SUBROUTINE imzd(n, e, matz, skew, z, ierr)

! ****

!  FUNCTION  -  COMPUTE THE EIGENVALUES AND OPTIONALLY THE EIGENVECTORS OF A
!                 SYMMETRIC TRIDIAGONAL MATRIX WITH ZERO DIAGONALS OR A SKEW-
!                 SYMMETRIC TRIDIAGONAL MATRIX USING AN IMPLICIT QR-TYPE
!                 ITERATION

!  PARAMETERS

!     N        - INPUT INTEGER SPECIFYING THE ORDER OF THE TRIDIAGONAL MATRIX

!     E(N)     - ON INPUT, ARRAY CONTAINING THE LOWER SUBDIAGONAL ELEMENTS OF
!                  THE TRIDIAGONAL MATRIX IN ITS LAST N-1 POSITIONS.
!                  E(1) IS ARBITRARY.
!                ON OUTPUT, ARRAY CONTAINS THE EIGENVALUES. THE NON-ZERO
!                  EIGENVALUES OCCUR IN PAIRS WITH OPPOSITE SIGNS AND ARE FOUND
!                  IN ADJACENT LOCATIONS IN E. THE EIGENVALUES OF SYMMETRIC
!                  MATRICES ARE REAL AND THE EIGENVALUES OF SKEW-SYMMETRIC
!                  MATRICES ARE PURELY IMAGINARY COMPLEX NUMBERS.  IF AN ERROR
!                  EXIT IS MADE, THE EIGENVALUES ARE CORRECT FOR INDICES
!                  IERR+1, IERR+2...N

!     MATZ     - INPUT LOGICAL VARIABLE SPECIFYING THE EIGENVECTOR
!                  OPTION
!                  = .TRUE.   EIGENVECTORS ARE TO BE COMPUTED
!                  = .FALSE.  EIGENVECTORS ARE NOT TO BE COMPUTED

!     SKEW     - INPUT LOGICAL VARIABLE SPECIFYING TYPE OF INPUT MATRIX
!                  = .TRUE.   INPUT TRIDIAGONAL MATRIX IS SKEW-SYMMETRIC
!                  = .FALSE.  INPUT TRIDIAGONAL MATRIX IS SYMMETRIC WITH ZERO
!                               DIAGONALS
!                  SKEW IS NOT REFERENCED IF MATZ = .FALSE.

!     Z(NZ,N)  - OUTPUT ARRAY CONTAINING THE ORTHOGONAL EIGENVECTORS OF THE
!                  INPUT TRIDIAGONAL MATRIX. EIGENVECTORS CORRESPONDING TO ZERO
!                  EIGENVALUES ARE NORMALIZE TO UNIT 2-NORM (LENGTH) AND THOSE
!                  CORRESPONDING TO NON-ZERO EIGENVALUES HAVE 2-NORM OF SQUARE
!                  ROOT 2.  IF THE J-TH EIGENVALUE IS ZERO OR REAL (I.E. E(J)),
!                  ITS EIGENVECTOR IS FOUND IN THE J-TH COLUMN OF Z.
!                  IF THE J-TH EIGENVALUE IS IMAGINARY (I.E. E(J)*I) WITH
!                  E(J+1) = -E(J), THE REAL PART OF ITS EIGENVECTOR IS FOUND IN
!                  THE J-TH COLUMN OF Z AND ITS IMAGINARY PART FOUND IN THE
!                  (J+1)-TH COLUMN.  IF AN ERROR EXIT IS MADE, Z CONTAINS THE
!                  EIGENVECTORS ASSOCIATED WITH THE STORED EIGENVALUES.
!                  Z IS NOT REFERENCED IF MATZ = .FALSE.

!     IERR     - OUTPUT ERROR CODE
!                  = 0   NORMAL RETURN (ALL EIGENVALUES/VECTORS FOUND)
!                  = J   IF THE J-TH EIGENVALUE HAS NOT BEEN DETERMINED AFTER
!                          30 ITERATIONS

!  REQUIRED FUNCTIONS - ABS,SIGN,SQRT,MOD

! ****

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: e(:)
LOGICAL, INTENT(IN)     :: matz
LOGICAL, INTENT(IN)     :: skew
REAL (dp), INTENT(OUT)  :: z(:,:)
INTEGER, INTENT(OUT)    :: ierr

REAL (dp)  :: f, g, q, c, s, r, p, test, tmag
INTEGER    :: i, j, k, l, m, l0, l0m1, m0, ls, im1, jp1, km1, kp1, lm1,  &
              mm1, ip3, ieo, its, ip1
REAL (dp), PARAMETER :: eps = EPSILON( 0.0_dp )

IF (matz) THEN

! *** PLACE IDENTITY MATRIX IN Z

  DO  i = 1, n
    z(i,1:n) = 0.
    z(i,i) = 1.
  END DO
END IF

ierr = 0
m = n
mm1 = m - 1
e(1) = 0.
its = 0

30 IF (m >= 2) THEN
  m0 = m

! *** SEARCH FOR NEXT SUBMATRIX TO SOLVE  (MATRIX SPLITTING)

  f = 0.
  DO  i = 1, mm1
    j = m - i
    jp1 = j + 1
    g = ABS(e(jp1))
    tmag = ABS(e(j)) + f
    test = tmag + g
    IF (ABS(test - tmag) < eps*tmag) GO TO 50
    f = g
  END DO
  jp1 = 1

  50 l0 = jp1 + 1
  l0m1 = jp1
  IF (l0m1 == m) GO TO 160
  IF (matz) THEN
    IF (skew) THEN

! *** PLACE CORRECT SIGN ON IDENTITY DIAGONALS

      DO  i = l0m1, m, 4
        z(i,i) = -z(i,i)
        ip3 = i + 3
        IF (ip3 > m) GO TO 70
        z(ip3,ip3) = -z(ip3,ip3)
      END DO
    END IF
  END IF

  70 IF (l0 == m) GO TO 170
  ieo = m - l0
  ieo = MOD(ieo,2)
  l = l0
  IF (ieo == 0) GO TO 130

! *** FIND ZERO EIGENVALUE OF ODD ORDERED SUBMATRICES

  c = 0.
  s = -1.
  DO  i = l0, mm1, 2
    k = mm1 + l0 - i
    kp1 = k + 1
    q = -s * e(kp1)
    e(kp1) = c * e(kp1)
    IF (ABS(e(k)) <= ABS(q)) THEN
      c = e(k) / q
      r = SQRT(c*c+1.)
      e(k) = q * r
      s = 1. / r
      c = c * s
    ELSE
      s = q / e(k)
      r = SQRT(1.+s*s)
      e(k) = e(k) * r
      c = 1. / r
      s = s * c
    END IF
    IF (matz) THEN

! *** ACCUMULATE TRANSFORMATIONS FOR EIGENVECTORS

      km1 = k - 1
      z(km1,m) = -s * z(km1,km1)
      z(km1,km1) = c * z(km1,km1)
      DO  j = kp1, m, 2
        z(j,km1) = s * z(j,m)
        z(j,m) = c * z(j,m)
      END DO
    END IF

  END DO
  m = mm1
  mm1 = m - 1
  IF (l0 == m) GO TO 170

! *** CHECK FOR CONVERGENCE OR SMALL SUBDIAGONAL ELEMENT

  100 DO  i = l0, mm1, 2
    k = mm1 + l0 - i
    l = k + 1
    tmag = ABS(e(l)) + ABS(e(k-1))
    test = tmag + e(k)
    IF (ABS(test - tmag) < eps*tmag) GO TO 120
  END DO
  l = l0
  120 IF (l == m) GO TO 170

! *** FORM SHIFT

  130 its = its + 1
  IF (its > 30) GO TO 220
  f = e(m-3)
  g = e(m-2)
  c = e(mm1)
  s = e(m)
  p = ((c-f)*(c+f)+(s-g)*(s+g)) / (2.*g*c)
  r = SQRT(p*p+1.)
  q = (g/(p+SIGN(r,p))) - c
  f = e(l)
  lm1 = l - 1
  e(lm1) = ((f-s)*(f+s)+c*q) / f

! *** PERFORM ONE IMPLICIT QR ITERATION ON CHOLESKY FACTOR

  ls = l0m1
  c = 1.
  s = 1.
  DO  i = l, mm1
    ip1 = i + 1
    im1 = i - 1
    q = s * e(ip1)
    e(ip1) = c * e(ip1)
    IF (ABS(e(im1)) <= ABS(q)) THEN
      c = e(im1) / q
      r = SQRT(c*c+1.)
      e(im1) = q * r
      s = 1. / r
      c = c * s
    ELSE
      s = q / e(im1)
      r = SQRT(1.+s*s)
      e(im1) = e(im1) * r
      c = 1. / r
      s = s * c
    END IF
    f = e(ip1)
    e(ip1) = -s * e(i) + c * f
    e(i) = c * e(i) + s * f
    IF (matz) THEN

! *** ACCUMULATE TRANSFORMATIONS FOR EIGENVECTORS

      DO  j = ls, m0, 2
        f = z(j,ip1)
        z(j,ip1) = -s * z(j,im1) + c * f
        z(j,im1) = c * z(j,im1) + s * f
      END DO
      IF (ls /= l0m1) THEN
        ls = l0m1
      ELSE
        ls = l0
      END IF
    END IF
  END DO
  e(lm1) = 0.
  GO TO 100

! *** ITERATION CONVERGED TO ONE ZERO EIGENVALUE

  160 e(m) = 0.
  m = mm1
  GO TO 180

! *** ITERATION CONVERGED TO EIGENVALUE PAIR

  170 e(mm1) = e(m)
  e(m) = -e(m)
  m = m - 2

  180 its = 0
  mm1 = m - 1
  IF (m > l0) GO TO 100
  IF (m == l0) GO TO 170
  IF (.NOT.matz) GO TO 30
  IF (skew) GO TO 30

! *** COMPUTE EIGENVECTORS FROM ORTHONORMAL COLUMNS OF Z IF NOT SKEW

  190 k = m0
  200 IF (e(k) /= 0.) THEN
    km1 = k - 1
    DO  j = l0m1, m0, 2
      z(j,k) = z(j,km1)
      f = z(j+1,k)
      z(j+1,km1) = f
      z(j+1,k) = -f
    END DO
    k = km1
  END IF
  k = k - 1
  IF (k > l0m1) GO TO 200
  IF (ierr /= 0) GO TO 230
  GO TO 30

! *** ERROR EXIT

  220 ierr = m
  IF (matz) THEN
    IF (.NOT.skew) GO TO 190
  END IF
END IF

230 RETURN
END SUBROUTINE imzd

SUBROUTINE tbakzd(n, a, m, z)

! ****

!  FUNCTION  -  FORMS THE EIGENVECTORS OF A REAL SKEW-SYMMETRIC MATRIX
!                 BY BACK TRANSFORMING THOSE OF THE CORRESPONDING SKEW-
!                 SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY  TRIZD

!  PARAMETERS

!     N        - INPUT INTEGER SPECIFYING THE ORDER OF A

!     A(NA,N)  - INPUT ARRAY CONTAINING INFORMATION ABOUT THE ORTHOGONAL
!                  TRANSFORMATIONS USED IN THE REDUCTION BY  TRIZD  IN
!                  ITS FULL LOWER TRIANGLE

!     M        - INPUT INTEGER SPECIFYING THE NUMBER OF EIGENVECTORS TO
!                  BE BACK TRANSFORMED

!     Z(NZ,M)  - ON INPUT, Z CONTAINS THE REAL AND IMAGINARY (IF COMPLEX)
!                  PARTS OF THE EIGENVECTORS TO BE BACK TRANSFORMED IN ITS
!                  FIRST M COLUMNS
!                ON OUTPUT, Z CONTAINS THE REAL AND IMAGINARY (IF COMPLEX)
!                  PARTS OF THE TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS

! ****

INTEGER, INTENT(IN)        :: n
REAL (dp), INTENT(IN)      :: a(:,:)
INTEGER, INTENT(IN)        :: m
REAL (dp), INTENT(IN OUT)  :: z(:,:)

REAL (dp)  :: h, s
INTEGER    :: i, j, l

IF (m /= 0) THEN
  IF (n /= 1) THEN

    DO  i = 2, n
      l = i - 1
      h = a(i,i)
      IF (h /= 0.0_dp) THEN

        DO  j = 1, m
          s = DOT_PRODUCT( a(i,1:l), z(1:l,j) )

          s = (s/h) / h

          z(1:l,j) = z(1:l,j) - s * a(i,1:l)

        END DO
      END IF

    END DO
  END IF
END IF

RETURN
END SUBROUTINE tbakzd

END MODULE skew_symmetric

PROGRAM driver

! Code converted using TO_F90 by Alan Miller
! Date: 1999-10-29  Time: 18:49:08

! ****

!  FUNCTION  -  THIS IS THE MAIN PROGRAM (DRIVER) FOR ILLUSTRATING THE
!                 USE OF SUBROUTINES TRIZD, IMZD, AND TBAKZD.

!  REFERENCES - EIGENSYSTEM COMPUTATION FOR SKEW-SYMMETRIC MATRICES AND
!                 A CLASS OF SYMMETRIC MATRICES, WARD,R C AND GRAY,L J.
!                 TO APPEAR IN MANUSCRIPT SECTION OF ACM-TOMS.

!               AN ALGORITHM FOR COMPUTING THE EIGENSYSTEM OF SKEW-
!                 SYMMETRIC MATRICES AND A CLASS OF SYMMETRIC MATRICES,
!                 TO APPEAR IN ALGORITHM SECTION OF ACM-TOMS.

!  REQUIRED FUNCTIONS FOR DRIVER AND SUBROUTINES - ABS,SIGN,SQRT,MOD

! ****

USE skew_symmetric

IMPLICIT NONE
REAL (dp)  :: a(6,6), z(6,6), e(6)
REAL (dp)  :: con
INTEGER    :: i, j, n, im1, jp1, ierr
LOGICAL    :: matz, skew

matz = .true.

! *** SET UP SKEW-SYMMETRIC TEST CASE

WRITE (6,5000)
n = 5
skew = .true.

! *** READ AND PRINT TEST MATRIX

WRITE (6,5100)
DO  i = 1, n
  READ (5,5200) a(i,1:n)
  WRITE (6,5200) a(i,1:n)
END DO

! *** COMPUTE EIGENVALUES AND EIGENVECTORS

CALL trizd(n, a, e)
CALL imzd(n, e, matz, skew, z, ierr)
IF (ierr /= 0) WRITE (6,5300) ierr
CALL tbakzd(n, a, n, z)

! *** PRINT EIGENVALUES AND EIGENVECTORS

WRITE (6,5400)
j = 0
20 j = j + 1
WRITE (6,5500)
IF (e(j) /= 0.d0) THEN
  jp1 = j + 1
  WRITE (6,5600) e(j), z(1,j), z(1,jp1)
  WRITE (6,5700) (z(i,j), z(i,jp1), i = 2,n)
  WRITE (6,5500)
  con = -z(1,jp1)
  WRITE (6,5600) e(jp1), z(1,j), con
  DO  i = 2, n
    con = -z(i,jp1)
    WRITE (6,5700) z(i,j), con
  END DO
  j = j + 1
ELSE
  WRITE (6,5800) e(j), z(1,j)
  WRITE (6,5900) z(2:n,j)
END IF
IF (j < n) GO TO 20

! *** SET UP TRIDIAGONAL, SYMMETRIC, ZERO DIAGONAL TEST CASE

WRITE (6,6000)
n = 6
skew = .false.
DO  i = 1, n
  e(i) = 1.
  DO  j = 1, n
    a(i,j) = 0.
  END DO
END DO
DO  i = 2, n
  im1 = i - 1
  a(i,im1) = e(i)
  a(im1,i) = e(i)
END DO

! *** PRINT TEST MATRIX

WRITE (6,6100)
DO  i = 1, n
  WRITE (6,5200) a(i,1:n)
END DO

! *** COMPUTE EIGENVALUES AND EIGENVECTORS

CALL imzd(n, e, matz, skew, z, ierr)
IF (ierr /= 0) WRITE (6,5300) ierr

! *** PRINT EIGENVALUES AND EIGENVECTORS

WRITE (6,6200)
DO  j = 1, n
  WRITE (6,5500)
  WRITE (6,5800) e(j), z(1,j)
  WRITE (6,5900) z(2:n,j)
END DO
STOP

5000 FORMAT ('1', 'EIGENSYSTEM COMPUTATION OF SKEW-SYMMETRIC TEST CASE'//)
5100 FORMAT ('0', '         TEST MATRIX'/)
5200 FORMAT (6F6.0)
5300 FORMAT ('0'/'0', 'IMZD IERR =', i5)
5400 FORMAT ('0'/'0', '  EIGENVALUES', t40, 'EIGENVECTORS')
5500 FORMAT (/)
5600 FORMAT (' ', e15.8, ' * I     ', e15.8, '  +  ', e15.8, ' * I')
5700 FORMAT (t26, e15.8, '  +  ', e15.8, ' * I')
5800 FORMAT (' ', e15.8, t26, e15.8)
5900 FORMAT (t26, e15.8)
6000 FORMAT ('1', 'EIGENSYSTEM COMPUTATION OF TRIDIAGONAL, SYMMETRIC,',  &
             ' ZERO DIAGONAL TEST CASE'//)
6100 FORMAT ('0', t14, 'TEST MATRIX'/)
6200 FORMAT ('0'/'0', '  EIGENVALUES             EIGENVECTORS')
END PROGRAM driver


*
* Program cubictable - print out the values for a cubic function
*
* Written by - Charles Severance 12Mar92
*
      REAL X,FUN
*
      DO X=-3.0,3.0,0.4
*
* Calculate the function
*
       FUN = (X ** 3) + 2 * (X ** 2) - X - 2.0
       PRINT *,X,FUN
      END DO
      END


! Reference - http://fortranwiki.org/fortran/show/Submodules
module stdlib_kinds
use iso_fortran_env, only: rkind1 => real32
use iso_fortran_env, only: int32
implicit none
public rkind1, int32
end module stdlib_kinds

module points
  use :: stdlib_kinds, only: rkind  => rkind1
  implicit none

  type :: point
     real :: x, y
  end type point

  interface
     module function point_dist_func(a, b) result(distance)
       type(point), intent(in) :: a, b
       real(rkind) :: distance
     end function point_dist_func
  end interface

  interface
     module subroutine point_dist_subrout(a, b, distance)
       type(point), intent(in) :: a, b
       real(rkind), intent(out) :: distance
     end subroutine point_dist_subrout
  end interface
end module points

submodule (points) points_a
contains
  module function point_dist_func(a, b) result(distance)
    type(point), intent(in) :: a, b
    real(rkind) :: distance
    distance = sqrt((a%x - b%x)**2 + (a%y - b%y)**2)
  end function point_dist_func

  module subroutine point_dist_subrout(a, b, distance)
    type(point), intent(in) :: a, b
    real(rkind), intent(out) :: distance
    distance = sqrt((a%x - b%x)**2 + (a%y - b%y)**2)
  end subroutine point_dist_subrout
end submodule points_a

program submodules_02
implicit none
end program


      subroutine gewpp(a,n)
      real a(n,n)

C     Gaussian elimination with partial pivoting (courtesy of Rob Schreiber)

      do k = 1, n-1
c     find pivot
         imax = k
         do i = k+1, n
            if (abs(a(i,k)) .gt. abs(a(imax,k))) then
               imax = i
            endif
         enddo
c     exchange elements and compute multipliers
         t = a(imax,k)
         a(imax, k) = a(k,k)
         a(k,k) = t
         do i = k+1, n
            a(i,k) = a(i,k) / a(k,k)
         enddo
c     a(i,j)  -= a(i,k) * a(k,j) for i, j > k
         do j = k+1, n
            t = a(imax, j)
            a(imax, j) = a(k,j)
            a(k,j) = t
            do i = k+1, n
               a(i,j) = a(i,j) - a(i,k) * a(k,j)
            enddo
         enddo
      enddo

      return
      end


module primes_mod
  implicit none

  logical, allocatable :: primes(:)

contains

subroutine Genprimes(parr)
  logical, intent(in out) :: parr(:)
  integer :: i
! Prime sieve
  parr = .true.
  parr (1) = .false.
  parr (4 : size(parr) : 2) = .false.
  do i = 3, int (sqrt (real (size(parr)))), 2
    if (parr(i)) parr(i * i : size(parr) : i) = .false.
  end do

end subroutine

function is_rtp(candidate)
  logical :: is_rtp
  integer, intent(in) :: candidate
  integer :: n

  is_rtp = .true.
  n = candidate / 10
  do while(n > 0)
    if(.not. primes(n)) then
      is_rtp = .false.
      return
    end if
    n = n / 10
  end do

end function

function is_ltp(candidate)
  logical :: is_ltp
  integer, intent(in) :: candidate
  integer :: i, n
  character(10) :: nstr

  write(nstr, "(i10)") candidate
  is_ltp = .true.
  do i = len_trim(nstr)-1, 1, -1
    n = mod(candidate, 10**i)
    if(.not. primes(n)) then
      is_ltp = .false.
      return
    end if
  end do
end function

end module primes_mod

program Truncatable_Primes
  use primes_mod
  implicit none

  integer, parameter :: limit = 999999
  integer :: i
  character(10) :: nstr

! Generate an array of prime flags up to limit of search
  allocate(primes(limit))
  call Genprimes(primes)

! Find left truncatable prime
  do i = limit, 1, -1
    write(nstr, "(i10)") i
    if(index(trim(nstr), "0") /= 0) cycle      ! check for 0 in number
    if(is_ltp(i)) then
      write(*, "(a, i0)") "Largest left truncatable prime below 1000000 is ", i
      exit
    end if
  end do

! Find right truncatable prime
  do i = limit, 1, -1
    write(nstr, "(i10)") i
    if(index(trim(nstr), "0") /= 0) cycle      ! check for 0 in number
    if(is_rtp(i)) then
      write(*, "(a, i0)") "Largest right truncatable prime below 1000000 is ", i
      exit
    end if
  end do
end program


      SUBROUTINE sla_DCC2S (V, A, B)
*+
*     - - - - - -
*      D C C 2 S
*     - - - - - -
*
*  Direction cosines to spherical coordinates (double precision)
*
*  Given:
*     V     d(3)   x,y,z vector
*
*  Returned:
*     A,B   d      spherical coordinates in radians
*
*  The spherical coordinates are longitude (+ve anticlockwise
*  looking from the +ve latitude pole) and latitude.  The
*  Cartesian coordinates are right handed, with the x axis
*  at zero longitude and latitude, and the z axis at the
*  +ve latitude pole.
*
*  If V is null, zero A and B are returned.
*  At either pole, zero A is returned.
*
*  P.T.Wallace   Starlink   July 1989
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  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., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION V(3),A,B

      DOUBLE PRECISION X,Y,Z,R

      X = V(1)
      Y = V(2)
      Z = V(3)
      R = SQRT(X*X+Y*Y)

      IF (R.EQ.0D0) THEN
         A = 0D0
      ELSE
         A = ATAN2(Y,X)
      END IF

      IF (Z.EQ.0D0) THEN
         B = 0D0
      ELSE
         B = ATAN2(Z,R)
      END IF

      END


! computationally intensive core
subroutine kernel(anew, aold, sizeStart, sizeEnd)
    double precision, intent(out) :: anew(:,:)
    double precision, intent(in)  :: aold(:,:)
    integer, intent(in) :: sizeStart, sizeEnd
    integer             :: i, j

    do j = sizeStart, sizeEnd
        do i = sizeStart, sizeEnd
            anew(i,j)= aold(i,j)/2.0  &
                +(aold(i-1,j)+aold(i+1,j)+aold(i,j-1)+aold(i,j+1))/8.0
        enddo
    enddo
end subroutine

! main routine
program stencil
    implicit none
    interface
        subroutine kernel(anew, aold, sizeStart, sizeEnd)
            double precision, intent(out) :: anew(:,:)
            double precision, intent(in)  :: aold(:,:)
            integer, intent(in) :: sizeStart, sizeEnd
        end subroutine
    end interface

    ! parameters for calculation
    integer             :: n=2400     ! n x n grid
    integer             :: energy=1   ! energy to be injected per iteration
    integer             :: niters=250 ! number of iterations

    ! other variables
    integer, parameter  :: nsources=3
    integer, dimension(3, 2)        :: sources
    double precision, allocatable   :: aold(:,:), anew(:,:)
    integer             :: iters, i, j, size, sizeStart, sizeEnd
    double precision    :: heat=0.0

    size = n + 2
    sizeStart = 2
    sizeEnd = n + 1

    allocate(aold(size, size))
    allocate(anew(size, size))
    aold = 0.0
    anew = 0.0

    sources(1,:) = (/ n/2,   n/2   /)
    sources(2,:) = (/ n/3,   n/3   /)
    sources(3,:) = (/ n*4/5, n*8/9 /)

    do iters = 1, niters, 2

        ! odd iteration: anew <- stencil(aold)

        ! computationally intensive core
        call kernel(anew, aold, sizeStart, sizeEnd)

        ! three-point energy insertion
        do i = 1, nsources
            anew(sources(i,1)+1, sources(i,2)+1) =  &
                anew(sources(i,1)+1, sources(i,2)+1) + energy
        enddo

        ! even iteration: aold <- stencil(anew)

        ! computationally intensive core
        call kernel(aold, anew, sizeStart, sizeEnd)

        ! three-point energy insertion
        do i = 1, nsources
            aold(sources(i,1)+1, sources(i,2)+1) =  &
                aold(sources(i,1)+1, sources(i,2)+1) + energy
        enddo

    enddo

    ! sum of grid points to get total heat
    heat = 0.0
    do j = sizeStart, sizeEnd
        do i = sizeStart, sizeEnd
            heat = heat + aold(i,j)
        end do
    end do

    ! show de result
    write(*, "('Heat: ' f0.4)") heat

    deallocate(aold)
    deallocate(anew)

end


!! HEAT stentil related

!! RHS
subroutine rhs_heat_1d(nxyz, lamdaxyz, ng, soln, b)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix
    real    ::  lamdax
    real, dimension(      1-ng:nxyz(1)+ng ) :: soln, b

    ix = nxyz(1)
    lamdax = lamdaxyz(1)
    do i=1, ix
        b(i) =  lamdax/2 * ( soln(i+1) + soln(i-1) ) &
            + (1 - lamdax)*soln(i)
    end do
end subroutine rhs_heat_1d

subroutine rhs_heat_2d(nxyz, lamdaxyz, ng, soln, b)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy
    real    ::  lamdax, lamday, dd
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: soln, b

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    dd = 1 - lamdax - lamday
    do j=1, jy
    do i=1, ix
        b(i,j) = lamdax/2 * ( soln(i+1, j  ) + soln(i-1, j  ) ) &
               + lamday/2 * ( soln(i,   j+1) + soln(i,   j-1) ) &
               + dd*soln(i,j)
    end do
    end do
end subroutine rhs_heat_2d

subroutine rhs_heat_3d(nxyz, lamdaxyz, ng, soln, b)
implicit none
    integer, dimension(3) :: nxyz
    real   , dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy, k, kz
    real    ::  lamdax, lamday, lamdaz, dd
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln, b

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)
    dd = 1 - lamdax - lamday -lamdaz
    do k=1, kz
    do j=1, jy
    do i=1, ix
        b(i,j,k) = lamdax/2 * ( soln(i+1, j,   k  ) + soln(i-1, j,   k  ) ) &
                 + lamday/2 * ( soln(i,   j+1, k  ) + soln(i,   j-1, k  ) ) &
                 + lamdaz/2 * ( soln(i,   j,   k+1) + soln(i,   j,   k-1) ) &
                 + dd*soln(i,j,k)
    end do
    end do
    end do
end subroutine rhs_heat_3d

subroutine stencil_heat_1d(nxyz, lamdaxyz, ng, soln, A)
implicit none
    integer, dimension(3) :: nxyz
    real,    dimension(3) :: lamdaxyz
    real    :: lamdax
    integer ::  ng, i, ix
    real, dimension(      1-ng:nxyz(1)+ng ) :: soln
    real, dimension(1:3,  1-ng:nxyz(1)+ng ) :: A

    ix = nxyz(1)
    lamdax = lamdaxyz(1)
    do i=1, ix
        A(1, i) = -0.5*lamdax
        A(2, i) = -0.5*lamdax
        A(3, i) = 1 + lamdax
    end do
end subroutine stencil_heat_1d

subroutine stencil_heat_2d(nxyz, lamdaxyz, ng, soln, A)
implicit none
    integer, dimension(3) :: nxyz
    real,    dimension(3) :: lamdaxyz
    real    :: lamdax, lamday
    integer ::  ng, i, ix, j, jy
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: soln
    real, dimension(1:5,  1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    do j=1, jy
    do i=1, ix
        A(1, i, j) = -0.5*lamdax
        A(2, i, j) = -0.5*lamdax
        A(3, i, j) = -0.5*lamday
        A(4, i, j) = -0.5*lamday
        A(5, i, j) = 1 + lamdax + lamday
    end do
    end do
end subroutine stencil_heat_2d

subroutine stencil_heat_3d(nxyz, lamdaxyz, ng, soln, A)
implicit none
    integer, dimension(3) :: nxyz
    real,    dimension(3) :: lamdaxyz
    integer ::  ng, i, ix, j, jy, k, kz
    real    ::  lamdax, lamday, lamdaz, dd
    real, dimension(      1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: soln
    real, dimension(1:7,  1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
    lamdax = lamdaxyz(1)
    lamday = lamdaxyz(2)
    lamdaz = lamdaxyz(3)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        A(1, i, j, k) = -0.5*lamdax
        A(2, i, j, k) = -0.5*lamdax
        A(3, i, j, k) = -0.5*lamday
        A(4, i, j, k) = -0.5*lamday
        A(5, i, j, k) = -0.5*lamdaz
        A(6, i, j, k) = -0.5*lamdaz
        A(7, i, j, k) = 1 + lamdax + lamday + lamdaz
    end do
    end do
    end do
end subroutine stencil_heat_3d


MODULE laplace

CONTAINS
  SUBROUTINE redblack(a,residue)
    INTEGER, PARAMETER :: N = 20
    ! Due to limitations within the NAG F90 compiler,
    ! N must be declared constant, rather than passed
    ! into the subroutine
    REAL,    INTENT(out) :: residue
    REAL,    DIMENSION (N,N), INTENT(inout) :: a

    REAL,    DIMENSION (N,N) :: old_a
    LOGICAL, DIMENSION (N,N) :: even

    DO j = 1,N
      DO i = 1,N
        EVEN (i,j) = (MOD(i+j,2) == 0)
      ENDDO
    ENDDO

!---- Red-black relaxation:
    old_a = a
    WHERE (even(2:N-1,2:N-1))
      a (2:N-1,2:N-1) = 0.4 * a (2:N-1,2:N-1)                             &
                      - 0.6 * 0.25 * ( a(1:N-2,2:N-1) + a(3:N,2:N-1)      &
                                     + a(2:N-1,1:N-2) + a(2:N-1,3:N))
    ELSEWHERE
      a (2:N-1,2:N-1) = 0.4 * a (2:N-1,2:N-1)                             &
                      - 0.6 * 0.25 * ( a(1:N-2,2:N-1) + a(3:N,2:N-1)      &
                                     + a(2:N-1,1:N-2) + a(2:N-1,3:N))
    ENDWHERE

    residue = 0
    DO j = 1,N
      DO i = 1,N
        IF (ABS(a(i,j)-old_a(i,j)) > residue) THEN
          residue = ABS(a(i,j)-old_a(i,j))
        ENDIF
      ENDDO
    ENDDO
  END SUBROUTINE

END MODULE laplace


PROGRAM main
    USE io, ONLY: read_config, read_data, write_u
    USE calculate, ONLY: initial_guess, construct_matrix, construct_b, solve, &
        rel_err
    IMPLICIT NONE
    ! Initialize
    INTEGER :: n_body, n, m
    DOUBLE PRECISION :: dt, t0, tf, error, eps, relax
    DOUBLE PRECISION, ALLOCATABLE :: masses(:), x0(:,:), xf(:,:), u_bar(:), &
        A(:,:), u_star(:), u(:), b(:)
    CALL read_config(n_body, dt, t0, tf, eps, relax)
    n = (tf-t0)/dt + 1
    m = 2*3*n_body*n
    ALLOCATE(masses(n_body), x0(3, n_body), xf(3, n_body), u_bar(m), A(m,m), &
        u_star(m), u(m), b(m))
    CALL read_data(n_body, masses, x0, xf)
    CALL initial_guess(n_body, n, m, x0, xf, u_bar)
    CALL construct_matrix(masses, dt, n_body, n, m, A)

    ! Solve
    error = 1
    DO WHILE (error > eps)
        CALL construct_b(u_bar, masses, n_body, m, n, b)
        CALL solve(A, b, m, u_star, error)
        u = relax*u_star + (1-relax)*u_bar
!       CALL rel_err(u_star, u_bar, m, error)
        CALL write_u(u, n, n_body, dt, t0,  m, error)
        u_bar = u
!       error = eps
    END DO

END PROGRAM


C$Procedure  VRELG ( Vector relative difference, general dimension )

      DOUBLE PRECISION FUNCTION VRELG ( V1, V2, NDIM )

C$ Abstract
C
C   Return the relative difference between two vectors of general
C   dimension.
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     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V1 ( * )
      DOUBLE PRECISION      V2 ( * )
      INTEGER               NDIM

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C      V1,V2     I   Input vectors.
C      NDIM      I   Dimension of V1 and V2.
C
C$ Detailed_Input
C
C      V1, V2        are two vectors for which the relative difference
C                    is to be computed.
C
C      NDIM          is the dimension of V1 and V2.
C
C$ Detailed_Output
C
C      VRELG         is the relative difference between V1 and V2.
C                    It is defined as:
C                                             || V1 - V2 ||
C                              VRELG  =   ----------------------
C                                         MAX ( ||V1||, ||V2|| )
C
C                    where || X || indicates the Euclidean norm of
C                    the vector X.
C
C                    VRELG assumes values in the range [0,2]. If both
C                    V1 and V2 are zero vectors then VRELG is defined
C                    to be zero.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     If both V1 and V2 are zero vectors then VRELG is defined to be
C     zero.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function computes the relative difference between two vectors
C     of general dimension as defined above.
C
C     The function VREL may be used to find the relative difference
C     for two 3-dimensional vectors.
C
C$ Examples
C
C     This example determines if the state of Jupiter, with respect
C     to Voyager 2, for a set of times is the same for two different
C     ephemeris files. Instead of insisting on absolute equality
C     between the state vectors, the program will check if the relative
C     difference between the vectors is greater than a fixed tolerance.
C
C     C
C     C     The NAIF code for Jupiter is 599 and for Voyager 2 is -32.
C     C     Set the tolerance to be 0.0005.
C     C
C           INTEGER               JUP
C           PARAMETER           ( JUP = 599 )
C
C           INTEGER               VG2
C           PARAMETER           ( VG2 = -32 )
C
C           INTEGER               NUM
C           PARAMETER           ( NUM = 500 )
C
C           DOUBLE PRECISION      TOL
C           PARAMETER           ( TOL = 5.D-04 )
C
C     C
C     C     Spicelib function
C     C
C           DOUBLE PRECISION      VRELG
C     C
C     C     Local variables
C     C
C           DOUBLE PRECISION      STATE1 ( 6, NUM )
C           DOUBLE PRECISION      STATE2 ( 6, NUM )
C           DOUBLE PRECISION      ET     (    NUM )
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      DIFF
C
C           INTEGER               HANDLE
C           INTEGER               I
C
C           .
C           .
C           .
C
C           C
C           C     Load  the first SPK file.
C           C
C                 CALL SPKLEF ( 'VG2_SOURCE_1.BSP', HANDLE )
C           C
C           C     Find the states for each time in the array ET.
C           C     This example assumes that the SPK file can
C           C     provide states for all of the times in the array.
C           C
C                 DO I = 1, NUM
C
C                    CALL SPKEZ ( JUP, ET(I),      'J2000', 'LT',
C                .                VG2, STATE1(1,I), LT           )
C
C                 END DO
C           C
C           C     Unload the first file and load the second one.
C           C
C                 CALL SPKUEF ( HANDLE )
C
C                 CALL SPKLEF ( 'VG2_SOURCE_2.BSP', HANDLE )
C           C
C           C     Find the states from the new file.
C           C
C                 DO I = 1, NUM
C
C                    CALL SPKEZ ( JUP, ET(I),      'J2000', 'LT',
C                .                VG2, STATE2(1,I), LT           )
C
C                 END DO
C           C
C           C     Now compare the two state vectors for each time.
C           C
C                 DO I = 1, NUM
C
C                    DIFF = VRELG ( STATE1(1,I), STATE2(1,I), 6 )
C
C                    IF ( DIFF .GT. TOL ) THEN
C
C                       .
C                       .
C                       .
C
C                    END IF
C
C                 END DO
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 15-JUN-1992 (JML)
C
C-&

C$ Index_Entries
C
C     relative difference of n-dimensional vectors
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORMG
      DOUBLE PRECISION      VDISTG

C
C     Local variables
C
      DOUBLE PRECISION      NUNORM
      DOUBLE PRECISION      DENORM

C
C     If the numerator is zero then set VRELG equal to zero. Otherwise,
C     perform the rest of the calculation.
C
C     This handles the case where both vectors are zero vectors since
C     the distance between them will be zero.
C
      NUNORM = VDISTG ( V1, V2, NDIM )

      IF ( NUNORM .EQ. 0.D0 ) THEN

         VRELG = 0.D0

      ELSE

         DENORM = MAX (  VNORMG(V1,NDIM), VNORMG(V2,NDIM)  )

         VRELG = NUNORM / DENORM

       END IF

      RETURN
      END


module collatz_conjecture
  implicit none
contains

  integer function steps(i)
    integer :: i
    integer :: j
    if (i<1) then
      steps=-1
      return
    endif
    steps=0
    j = i
    do while (j>1)
      steps=steps+1
      if (mod(j,2)==0) then ! is even
        j=j/2
      else
        j=3*j+1
      endif
    end do

  end function

end module


program tarefa1

    print *,'Digite a, b e c, respectivamente:'
    !Recebe os valores de a, b e c
    read(*,*) a, b, c

    !Calcula o discriminante
    delta = (b**2) - (4*a*c)

    !Verifica cada condição do discriminante
    if (delta.eq.0) then
        x1 = (-b + sqrt(delta))/(2*a)
        print '(A10,I1)', "#Raízes:", 1
        print '(A4,F8.5)', "X1: ", x1
    else if (delta.gt.0) then
        x1 = (-b + sqrt(delta))/(2*a)
        x2 = (-b - sqrt(delta))/(2*a)

        print '(A10,I1)', "#Raízes: ", 2
        print '(A4,F8.5)', "X1: ", x1
        print '(A4,F8.5)', "X2: ", x2
    else
        print '(A10,I1)', "#Raízes: ", 0
    end if

end program tarefa1


        subroutine idd_sffti1(ind,n,wsave)
c
c       routine idd_sffti serves as a wrapper around
c       the present routine; please see routine idd_sffti
c       for documentation.
c
        implicit none
        integer ind,n,k
        real*8 r1,twopi,wsave(2*(2+15+4*n)),fact
c
        r1 = 1
        twopi = 2*4*atan(r1)
c
c
        fact = 1/sqrt(r1*n)
c
c
        do k = 1,n
          wsave(k) = cos(twopi*(k-1)*ind/(r1*n))*fact
        enddo ! k
c
        do k = 1,n
          wsave(n+k) = -sin(twopi*(k-1)*ind/(r1*n))*fact
        enddo ! k
c
c
        return
        end
c
c
c
c


function SHConfidence(l_conf, r)
!------------------------------------------------------------------------------
!
!   This subroutine will calculate the probability that two sets of spherical
!   harmonic coefficients, which possess a correlation coefficients r, are
!   linearly correlated at a given degree. This is calucated according to
!   equation A7 in Pauer et al. (2007), which is from Eckhard 1984.
!
!   Calling Parameters
!
!       INPUT
!           l_conf      Degree to calculate confidence levels.
!           r           The correlation coefficient of two sets
!                       of spherical harmonic coeficients at degree l_conf.
!
!       OUTPUT
!           cl          The confidence level.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp) :: SHConfidence
    real(dp), intent(in) :: r
    integer, intent(in) :: l_conf
    real(dp) :: prod
    integer:: l, i

    SHConfidence = abs(r)
    prod = 1.0_dp

    do l = 2, l_conf, 1
        i = l - 1
        prod = prod * dble(2*i-1) / dble(2*i)
        SHConfidence = SHConfidence + prod * abs(r) * (1.0_dp - r**2)**(l-1)
    end do

end function SHConfidence


program test

  use shared_data
  use multigrid_2d

  implicit none

  real(num), dimension(:,:), allocatable :: utrue, vtrue
  real(num), dimension(:,:), allocatable :: upol, vpol
  real(num), dimension(:,:), allocatable :: divu

  real(num) :: L2

  ! 0. User options

  nx = 256
  ny = nx
  x_min = 0.0_num
  x_max = 1.0_num
  y_min = x_min
  y_max = x_max

  call setup !setup the shared data

  ! setup a test problem

  allocate(utrue(0:nx+1,0:ny+1)) !no need for ghosts in the test case
  allocate(vtrue(0:nx+1,0:ny+1))
  allocate(upol(0:nx+1,0:ny+1))
  allocate(vpol(0:nx+1,0:ny+1))
  allocate(divu(1:nx,1:ny))

  do iy = 0, ny+1
  do ix = 0, nx+1
    utrue(ix,iy) = - sin(1.0_num * pi * xc(ix))**2 &
      & * sin(2.0_num * pi * yc(iy))
    vtrue(ix,iy) =   sin(1.0_num * pi * yc(iy))**2 &
      & * sin(2.0_num * pi * xc(ix))

    upol(ix,iy) = utrue(ix,iy) - &
      & 0.2_num * pi * cos(2.0_num * pi * yc(iy)) &
      & * sin(2.0_num * pi * xc(ix))
    vpol(ix,iy) = vtrue(ix,iy) - &
      & 0.2_num * pi * sin(2.0_num * pi * yc(iy)) &
      & * cos(2.0_num * pi * xc(ix))
  enddo
  enddo

  do iy = 1, ny
  do ix = 1, nx
    divu(ix,iy) = (upol(ix+1,iy) - upol(ix-1,iy)) / 2.0_num / dx + &
            & (vpol(ix,iy+1) - vpol(ix,iy-1)) / 2.0_num / dy
  enddo
  enddo

  print *, 'max divu before cleaning',maxval(divu)
  L2 = sqrt(sum(abs(utrue(1:nx,1:ny)-upol(1:nx,1:ny))**2) / real(nx*ny,num))
  print *, 'L2 (utrue vs upol) before cleaning',L2
  L2 = sqrt(sum(abs(vtrue(1:nx,1:ny)-vpol(1:nx,1:ny))**2) / real(nx*ny,num))
  print *, 'L2 (vtrue vs vpol) before cleaning',L2

  ! solve it

  call solve_mg_2d(mgphi = phi, f =  divu, tol = 1e-12_num)

  ! correct it

  do iy = 1, ny
  do ix = 1, nx
    upol(ix,iy) = upol(ix,iy) - 0.5_num*(phi(ix+1,iy)-phi(ix-1,iy))/dx
    vpol(ix,iy) = vpol(ix,iy) - 0.5_num*(phi(ix,iy+1)-phi(ix,iy-1))/dy
  enddo
  enddo

  ! apply periodic bc to the polluted vels and then re calc divu
  upol(0,:) = upol(nx,:)
  upol(nx+1,:) = upol(1,:)
  upol(:,0) = upol(:,ny)
  upol(:,ny+1) = upol(:,1)
  vpol(0,:) = vpol(nx,:)
  vpol(nx+1,:) = vpol(1,:)
  vpol(:,0) = vpol(:,ny)
  vpol(:,ny+1) = vpol(:,1)

  do iy = 1, ny
  do ix = 1, nx
    divu(ix,iy) = (upol(ix+1,iy) - upol(ix-1,iy)) / 2.0_num / dx + &
            & (vpol(ix,iy+1) - vpol(ix,iy-1)) / 2.0_num / dy
  enddo
  enddo

  print *, 'max divu after cleaning',maxval(divu)
  L2 = sqrt(sum(abs(utrue(1:nx,1:ny)-upol(1:nx,1:ny))**2) / real(nx*ny,num))
  print *, 'L2 (utrue vs upol) after cleaning',L2
  L2 = sqrt(sum(abs(vtrue(1:nx,1:ny)-vpol(1:nx,1:ny))**2) / real(nx*ny,num))
  print *, 'L2 (vtrue vs vpol) after cleaning',L2

end program test


module util

    ! Utilities used in other modules and elsewhere in the code

contains

    subroutine cross(ax,ay,az,bx,by,bz,cx,cy,cz)

        real ax,ay,az,bx,by,bz,cx,cy,cz

        cx = ay*bz - az*by
        cy = az*bx - ax*bz
        cz = ax*by - ay*bx

    end subroutine cross

    subroutine QuatRot(vx,vy,vz,Theta,nRx,nRy,nRz,Ox,Oy,Oz,vRx,vRy,vRz)

        ! % Perform rotation of vector v around normal vector nR using the
        ! % quaternion machinery.
        ! % v: input vector
        ! % Theta: rotation angle (rad)
        ! % nR: normal vector around which to rotate
        ! % Origin: origin point of rotation
        ! %
        ! % vR: Rotated vector

        real :: vx,vy,vz,Theta,nRx,nRy,nRz,Ox,Oy,Oz,vRx,vRy,vRz

        real :: p(4,1), pR(4,1), q(4), qbar(4), nRMag, vOx, vOy, vOz
        real :: QL(4,4), QbarR(4,4)

        ! Force normalize nR
        nRMag=sqrt(nRx**2+nRy**2+nRz**2)
        nRx=nRx/nRMag
        nRy=nRy/nRMag
        nRz=nRz/nRMag

        ! Quaternion form of v
        vOx=vx-Ox
        vOy=vy-Oy
        vOz=vz-Oz
        p=reshape((/0.0,vOx,vOy,vOz/),(/4,1/))

        ! Rotation quaternion and conjugate
        q=(/cos(Theta/2),nRx*sin(Theta/2),nRy*sin(Theta/2),nRz*sin(Theta/2)/)
        qbar=(/q(1),-q(2),-q(3),-q(4)/)

        QL=transpose(reshape((/q(1), -q(2), -q(3), -q(4), &
            q(2),  q(1), -q(4),  q(3), &
            q(3),  q(4),  q(1), -q(2), &
            q(4), -q(3),  q(2),  q(1)/),(/4,4/)))

        QbarR=transpose(reshape((/qbar(1), -qbar(2), -qbar(3), -qbar(4), &
            qbar(2),  qbar(1),  qbar(4), -qbar(3), &
            qbar(3), -qbar(4),  qbar(1),  qbar(2), &
            qbar(4),  qbar(3), -qbar(2),  qbar(1)/),(/4,4/)))

        ! Rotate p
        pR=matmul(matmul(QbarR,QL),p)
        vRx=pR(2,1)+Ox
        vRy=pR(3,1)+Oy
        vRz=pR(4,1)+Oz

    end subroutine QuatRot

    subroutine csvwrite(FID,Header,Data,WriteHead,NRows)

        integer :: FID, WriteHead, NRows
        character(10000) :: Header
        real :: Data(:,:)

        integer :: nRow, nCol, i, j

        ! Writes comma separated data to file specified by FID (assumed already opened with the open command).
        ! If WriteHead is 1, will write the input header line, else will skip header line.
        ! NRows is the number of rows of Data to write. If NRows<0, all rows of Data will be written...

        ! Write header
        if (WriteHead>0) then
            write (FID,'(A)') trim(Header)
        end if

        ! Write data
        if (NRows>=0) then
            nRow=NRows
        else
            nRow=size(Data,1)
        end if
        nCol=size(Data,2)
        do i=1,nRow
            do j=1,nCol
                if (j<nCol) then
                    write(FID,10) Data(i,j)
                else
                    write(FID,'(E14.7)') Data(i,j)
                end if
            end do
        end do

        return
10      format(E14.7,',',$)
    end subroutine Csvwrite

    subroutine file_to_stdout(filename)
    ! file_to_stdout() : Read a file in and write it's output to stdout.
    !   (Useful for appending input files to the output)

    integer, parameter :: max_linewidth = 1000
    character(80) :: filename
    integer :: reason

    character(max_linewidth) :: readline

    ! open file for reading
    open(30, file=filename)

    ! read in line by line
    do
        read(30, '(A)', iostat=reason) readline

        ! if end of file is reached, break out
        if (reason < 0) then
            exit
        else
            write(*,*) trim(readline)
        end if
    end do

    ! close file
    close(30)

    end subroutine file_to_stdout

    ! DEBUGGING FUNCTIONS !
    subroutine print_matrix_file(matrix,filename)
        real, allocatable :: matrix(:,:)
        character(80) :: filename

        open(27,file=filename)
        do i=1,size(matrix,dim=1)
            write(27,*) matrix(i,:)
        end do
        close(27)
    end subroutine print_matrix_file

    subroutine print_matrix_stdout(matrix)
        real, allocatable :: matrix(:,:)
        integer :: iounit

        do i=1,size(matrix,dim=1)
            write(*,*) matrix(i,:)
        end do
    end subroutine print_matrix_stdout

    subroutine print_vec3array(vec3array)
        real, allocatable :: vec3array(:,:)
        integer :: i

        do i=1,size(vec3array,dim=1)
            write(*,*) vec3array(i,:3)
        end do

    end subroutine print_vec3array

end module Util


program parabola
	real*8 t0,t1,t2,t,e,a1,a2
	t1=0.0;t0=1.0;t2=2.0;e=0.001;t=0.0;a1=0.0;a2=0.0
	open(14,file="Parabola")
	write(14,"(3(a13))")"t1","t0","t2"
	do
		write(14,"(f13.6,f13.6,f13.6)")t1,t0,t2
		a1=(t0**2.0-t2**2.0)*(8.0*t1**3-2.0*t1**2.0-7.0*t1+3.0)&
		+(t2**2.0-t1**2.0)*(8.0*t0**3.0-2.0*t0**2.0-7.0*t0+3.0)&
		+(t1**2.0-t0**2.0)*(8.0*t2**3.0-2.0*t2**2.0-7.0*t2+3.0)
		a1=a1/((t1-t0)*(t0-t2)*(t2-t1))
		a2=(t0-t2)*(8.0*t1**3-2.0*t1**2-7.0*t1+3.0)&
		+(t2-t1)*(8.0*t0**3-2.0*t0**2-7.0*t0+3.0)&
                +(t1-t0)*(8.0*t2**3-2.0*t2**2-7.0*t2+3)
		a2=a2/((t1-t0)*(t0-t2)*(t2-t1))
		t=a1/(2*a2)
		if((((t-t0)**2)**0.5)<e)exit
		if(t-t0)10,10,20
		10 if((8*t**3-2*t**2-7*t+3)-(8*t0**3-2*t0**2-7*t0+3))101,101,102
		20 if((8*t**3-2*t**2-7*t+3)-(8*t0**3-2*t0**2-7*t0+3))201,201,202
		101 t2=t0;t0=t; goto 30
		102 t1=t; goto 30
		201 t1=t0;t0=t; goto 30
		202 t2=t; goto 30
!程序编到此，继续编写两个if语句，
!记得拷地震学的电子书,以及还矩阵理论

		30 cycle
	end do
	write(14,"(f13.6,f13.6,f13.6,f13.6)")t1,t,t2,(8*t**3-2*t**2-7*t+3)
	close(14)
end program parabola


!=====================================================================!
! Module that solves linear systems using direct methods
!=====================================================================!

module direct_linear_solve

  ! import dependencies
  use iso_fortran_env, only : dp => REAL64
  use matrix_utils, only : print

  ! disable implicit datatypes
  implicit none

  ! restrict access to all functions
  private

  public :: tdma
  public :: dlufactor, dluppfactor
  public :: mgs_qrfactor, cgs_qrfactor, householder, banded_householder
  public :: householder_factorization, givens_factorization
  public :: givens, qriteration

contains

  !===================================================================!
  ! QR iteration to solve EVP
  !===================================================================!

  subroutine QRiteration(A, T, U, maxiters, tol)

    ! Arguments
    real(dp), intent(inout) :: A(:,:), U(:,:), T(:,:)
    integer , intent(in)    :: maxiters
    real(dp), intent(in)    :: tol

    ! Locals
    real(dp), allocatable   :: Q(:,:), R(:,:), D(:,:)
    real(dp) :: norm
    integer  :: k, i, n, m, iter
    real(dp) :: G(2,2)

    ! Initialize
    m = size(A,1)
    n = size(A,2)

    ! Copy A into T
    T = A

    ! Allocate space for QR factorization
    allocate(Q, R, D, mold=A)
    Q = 0
    R = 0
    D = 0

    ! Initialize Q with Identity
    U = 0
    do concurrent(i=1:n)
       U(i,i) = 1.0d0
    end do

    norm = huge(1.0d0)

    iter = 1
    do while (&
         & norm .gt. tol .or. &
         & iter .gt. maxiters)

       ! QR
       call givens_factorization(T, Q, R)
       call print(T)
       call print (Q)
       call print(R)

       stop
       ! A = RQ
       T = matmul(R,Q)

       ! Update transformation matrix
       U = matmul(U,Q)

       ! Elements below diagonal should have converged to zero to
       ! specified tolerance
       D = T
       do i = 1, n
          D(i,i) = 0.0d0
       end do
       norm = norm2(D)

       print *, n, iter , norm

       iter = iter + 1

    end do

    deallocate(R,Q,D)

  end subroutine QRiteration

  !===================================================================!
  ! QR facorization using Householder algorithm for banded matrix. The
  ! upper triangular part of a contains R.
  !===================================================================!

   subroutine banded_householder(A, p, q)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)
    integer, intent(in) :: p, q

    ! Local variables
    real(dp), allocatable :: x(:), v(:)
    integer  :: k, j, n, m, nrows, ncols
    real(dp) :: scalar

    allocate(x, source = A(:,1))
    allocate(v, source = A(:,1))

    ! Initialize
    nrows = size(A,1)
    ncols = size(A,2)

    cols: do k = 1, ncols

       m = min(nrows, k + p)

       !print *, m, nrows, k+p, k, ncols
       ! Extract the column below the diagonal
       x(k:m) = A(k:m, k)

       ! print *, x(k:m)

       ! Fimd the reflection vector
       v(k:m) = x(k:m)
       v(k) = v(k) + sign(norm2(x(k:m)),x(k))

       ! Normalize the reflection vector
       v(k:m) = v(k:m)/norm2(v(k:m))

       ! Perform householder transformation to zero out the lower
       ! entries except one for each column of the matrix
       do j = k , min(ncols,k+p+q) !limit to upper bandwidth
          !print *, 'tranforming col', j, 'rows ', k, m
          scalar = dot_product(v(k:m), A(k:m,j))
          A(k:m,j) = A(k:m,j) - 2.0_dp*scalar*v(k:m)
       end do

    end do cols

    deallocate(x,v)

  end subroutine banded_householder

  !===================================================================!
  ! QR facorization using Householder. The upper triangular part of a
  ! contains R.
  !===================================================================!

  pure subroutine householder(A)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)

    ! Local variables
    real(dp), allocatable :: x(:), v(:)
    integer  :: k, j, n, m
    real(dp) :: scalar

    allocate(x, source = A(:,1))
    allocate(v, source = A(:,1))

    ! Initialize
    m = size(A,1)
    n = size(A,2)

    cols: do k = 1, n

       x = 0
       v = 0

       ! Extract the column below the diagonal
       x(k:m) = A(k:m, k)

       ! Fimd the reflection vector
       v(k:m) = x(k:m)
       v(k) = v(k) + sign(norm2(x(k:m)),x(k))

       ! Normalize the reflection vector
       v(k:m) = v(k:m)/norm2(v(k:m))

       ! Perform householder transformation to zero out the lower
       ! entries except one for each column of the matrix
       do j = k , n
          scalar = dot_product(v(k:m), A(k:m,j))
          A(k:m,j) = A(k:m,j) - 2.0_dp*scalar*v(k:m)
       end do

    end do cols

    deallocate(x,v)

  end subroutine householder

  !===================================================================!
  ! QR facorization using Householder. The upper triangular part of a
  ! contains R.
  !===================================================================!

  pure subroutine householder_factorization(A, Q, R)

    ! Arguments
    real(dp), intent(in)  :: A(:,:)
    real(dp), intent(inout) :: Q(:,:), R(:,:)

    ! Local variables
    real(dp), allocatable :: x(:), v(:), ek(:)
    integer  :: k, j, n, m
    real(dp) :: scalar

    allocate(x, source = A(:,1))
    allocate(v, source = A(:,1))

    R = A

    ! Initialize
    m = size(A,1)
    n = size(A,2)

    findR: do k = 1, n

       ! Extract the column below the diagonal
       x(k:m) = R(k:m, k)

       ! Fimd the reflection vector
       v(k:m) = x(k:m)
       v(k) = v(k) + sign(norm2(x(k:m)),x(k))

       ! Normalize the reflection vector
       v(k:m) = v(k:m)/norm2(v(k:m))

       ! Perform householder transformation to zero out the lower
       ! entries except one for each column of the matrix
       do j = k , n
          scalar = dot_product(v(k:m), R(k:m,j))
          R(k:m,j) = R(k:m,j) - 2.0_dp*scalar*v(k:m)
       end do

    end do findR

    ! Form Q explicitly by dotting with identity vectors
    findQ: do k = n, 1, -1

       ! Extract the column below the diagonal
       x(k:m) = A(k:m, k)

       ! Fimd the reflection vector
       v(k:m) = x(k:m)
       v(k) = v(k) + sign(norm2(x(k:m)),x(k))

       ! Normalize the reflection vector
       v(k:m) = v(k:m)/norm2(v(k:m))

       ! Perform householder transformation to zero out the lower
       ! entries except one for each column of the matrix
       Q(k,k) = 1.0d0
       do j = k, n
          scalar = dot_product(v(k:m), Q(k:m,j))
          Q(k:m,j) = Q(k:m,j) - 2.0_dp*scalar*v(k:m)
       end do

    end do findQ

    deallocate(x,v)

  end subroutine householder_factorization

  !===================================================================!
  ! Take a 2-entry vector, perform Givens rotation and return the new
  ! vector in place of the old vector
  !===================================================================!

  pure subroutine givens(x)

    ! Arguments
    real(dp), intent(inout)  :: x(2)

    ! Locals
    real(dp) :: c, s, d, h

    ! Prevent division by zero
    if (x(2) .ne. 0.0d0) then

       ! Find sin and cosine
       h = hypot(x(1),x(2))
       d = 1.0d0/h
       c = abs(x(1))*d
       s = sign(d,x(1))*x(2)

       ! Set the new first entry
       x(1) = sign(1.0_dp,x(1))*h

    end if

    ! Zero out the second entry
    x(2) = 0.0d0

  end subroutine givens

  pure subroutine givens_rotation(x,y, G)

    real(dp), intent(in)  :: x, y
    real(dp), intent(out) :: G(2,2)
    real(dp) :: s, c, h

    ! Prevent division by zero
    if (y .eq. 0.0d0) then

       g(1,1) = 1.0d0
       g(2,2) = 1.0d0
       g(1,2) = 0.0d0
       G(2,1) = 0.0d0

    else

       h = hypot(x,y)

       c =  x/h
       s = -y/h

       g(1,1) = c
       g(2,2) = c
       g(1,2) = -s
       G(2,1) = s

    end if

  end subroutine givens_rotation

  !===================================================================!
  ! QR facorization using Givens rotation.
  !===================================================================!

  subroutine givens_factorization(A, Q, R)

    ! Arguments
    real(dp), intent(in)    :: A(:,:)
    real(dp), intent(inout) :: Q(:,:), R(:,:)

    integer  :: k, i, n, m
    real(dp) :: G(2,2)

    ! Get matrix size
    m = size(A,1)
    n = size(A,2)

    ! Copy matrix
    R = A

    ! Initialize Q with Identity
    do concurrent(i=1:n)
       Q(i,i) = 1.0d0
    end do

    ! Left multiply A by G to get R
    ! Right multiply G to get Q^T
    cols: do k = 1, n
       rows: do i = m-1, k, -1

          ! Form 2 by 2 block of G matrix
          call givens_rotation(R(i,k),R(i+1,k), G)

          ! Multiply only necessary rows and columns to form R and Q
          R(i:i+1,:) = matmul(G, R(i:i+1,:))
          Q(:,i:i+1) = matmul(Q(:,i:i+1),transpose(G))

       end do rows
    end do cols

  end subroutine givens_factorization

  !===================================================================!
  ! QR facorization using MGS
  !===================================================================!

  pure subroutine mgs_qrfactor(A, Q, R, info)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)
    real(dp), intent(inout)  :: Q(:,:)
    real(dp), intent(inout)  :: R(:,:)
    integer , intent(out)    :: info

    ! Local variables
    integer :: i, j, n

    ! Initialize
    n = size(A,2)

    R = 0

    cols: do i = 1, n
       Q(:,i) = A(:,i)
       row: do j = 1, i-1
          R(j,i) = dot_product(Q(:,j),Q(:,i))
          Q(:,i) = Q(:,i) - R(j,i)*Q(:,j)
       end do row
       R(i,i) = norm2(Q(:,i))
       Q(:,i) = Q(:,i)/R(i,i)
    end do cols

  end subroutine mgs_qrfactor

  !===================================================================!
  ! QR facorization using CGS
  !===================================================================!

  pure subroutine cgs_qrfactor(A, Q, R, info)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)
    real(dp), intent(inout)  :: Q(:,:)
    real(dp), intent(inout)  :: R(:,:)
    integer , intent(out)    :: info

    ! Local variables
    integer :: i, j, n

    ! Initialize
    n = size(A,2)

    R = 0
    cols: do i = 1, n
       Q(:,i) = A(:,i)
       row: do j = 1, i-1
          R(j,i) = dot_product(Q(:,j),A(:,i))
          Q(:,i) = Q(:,i) - R(j,i)*Q(:,j)
       end do row
       R(i,i) = norm2(Q(:,i))
       Q(:,i) = Q(:,i)/R(i,i)
    end do cols

  end subroutine cgs_qrfactor

  !===================================================================!
  ! Tridiagonal matrix algorithm for solving sparse tridiagonal
  ! systems using Thomas Algorithm. All input arrays are destroyed.
  !
  ! https://www.cfd-online.com/Wiki/Tridiagonal_matrix_algorithm_-_TDMA_(Thomas_algorithm)
  !===================================================================!

  pure subroutine tdma(mat, rhs, x)

    ! Arguments
    real(dp), intent(inout)  :: mat(:,:)
    real(dp), intent(inout)  :: rhs(:)
    real(dp), intent(out)    :: x(:)

    ! Local variables
    integer  :: k, n
    real(dp) :: m

    associate(A=>mat(:,1), B=>mat(:,2), C=>mat(:,3), D=>rhs)

      ! Find the size of linear system
      n = size(d)

      ! Forward elimination
      fwd_elim: do k = 2, n
         m = A(k)/b(k-1)
         b(k) = b(k) - m*c(k-1)
         d(k) = d(k) - m*d(k-1)
      end do fwd_elim

      ! Backward substitution
      x(n) = d(n)/b(n)
      back_sub: do k = n-1, 1, -1
         x(k) = (d(k)-c(k)*x(k+1))/b(k)
      end do back_sub

    end associate

   end subroutine tdma

  !===================================================================!
  ! Plain vanilla LU factorization algorithm without pivoting. How to
  ! store L and U into the original matrix (like LAPACK)?
  !===================================================================!

  pure subroutine dlufactor(A, L, U, info)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)
    real(dp), intent(inout)  :: L(:,:)
    real(dp), intent(inout)  :: U(:,:)
    integer , intent(out)    :: info

    ! Local variables
    integer :: k, j, m

    ! Initialize
    m = size(A,1)
    U = A
    do concurrent(k=1:m)
       L(k,k) = 1.0d0
    end do

    ! Algorithm
    do k = 1, m - 1
       do j = k + 1, m
          L(j,k) = U(j,k)/U(k,k)
          U(j,k:m) = U(j,k:m) - L(j,k)*U(k,k:m)
       end do
    end do

  end subroutine dlufactor

  !===================================================================!
  ! Swap two arrays
  !===================================================================!
  pure subroutine swap(a, b)
    real(dp), intent(inout), dimension(:) :: a, b
    real(dp), dimension(size(a)) :: work
    work = a
    a = b
    b = work
  end subroutine swap

  !===================================================================!
  ! LU factorization algorithm with partial pivoting
  !===================================================================!

  pure subroutine dluppfactor(A, L, U, P, info)

    ! Arguments
    real(dp), intent(inout)  :: A(:,:)
    real(dp), intent(inout)  :: L(:,:)
    real(dp), intent(inout)  :: U(:,:)
    real(dp), intent(inout)  :: P(:,:)
    integer , intent(out)    :: info

    ! Local variables
    integer :: k, j, m, pivot, i, jj

    ! Initialize
    m = size(A,1)
    U = A
    do concurrent(k=1:m)
       L(k,k) = 1.0d0
       P(k,k) = 1.0d0
    end do

    ! Algorithm
    do k = 1, m-1

       ! Find the entry in the left column with the largest absolute
       ! value. This entry is called the pivot.
       pivot = maxloc(abs(U(k:m,k)), dim = 1)
       i = pivot + k - 1

       ! Exchange rows
       call swap(U(k,k:m)   , U(i,k:m))
       call swap(L(k,1:k-1) , L(i,1:k-1))
       call swap(P(k,:)     , P(i,:))

       ! LU logic
       do j = k + 1, m
          L(j,k) = U(j,k)/U(k,k)
          U(j,k:m) = U(j,k:m) - L(j,k)*U(k,k:m)
       end do

    end do

  end subroutine dluppfactor

!!$  !===================================================================!
!!$  ! Plain vanilla LU factorization algorithm without pivoting
!!$  !===================================================================!
!!$
!!$  pure subroutine dgetlu(A, info)
!!$
!!$    real(dp), intent(inout)  :: A(:,:)
!!$    integer , intent(out)    :: info
!!$
!!$  end subroutine dgetlu

end module direct_linear_solve


program normalize
    use, intrinsic :: iso_fortran_env, only : error_unit, DP => REAL64
    implicit none
    integer, parameter :: rows = 3, cols = 4
    real(kind=DP), dimension(rows, cols) :: matrix, spread_norm
    real(kind=DP), dimension(rows) :: norm

    call random_number(matrix)
    print '(A)', 'original:'
    call print_matrix(matrix)

    norm = sum(matrix, dim=2)
    print '(A, *(F12.7))', 'norm:', norm

    spread_norm = spread(norm, 2, size(matrix, 2))
    call print_matrix(spread_norm)

    matrix = matrix/spread_norm
    print '(A)', 'row-normalized::'
    call print_matrix(matrix)

    norm = sum(matrix, dim=2)
    print '(A, *(F12.7))', 'norm:', norm

contains

    subroutine print_matrix(matrix)
        implicit none
        real(kind=DP), dimension(:, :), intent(in) :: matrix
        integer :: row

        do row = 1, size(matrix, 1)
            print '(*(F12.7))', matrix(row, :)
        end do
    end subroutine print_matrix

end program normalize


function epic_dist(fi1,tet1, fi2,tet2)
common/pi/pi,per

rz=6371.

cosf1=cos(fi1*per)
cost1=cos(tet1*per)
sinf1=sin(fi1*per)
sint1=sin(tet1*per)

cosf2=cos(fi2*per)
cost2=cos(tet2*per)
sinf2=sin(fi2*per)
sint2=sin(tet2*per)

x1=cosf1*cost1
y1=sinf1*cost1
z1=sint1

x2=cosf2*cost2
y2=sinf2*cost2
z2=sint2

dist = rz*sqrt((x2-x1)*(x2-x1)+(y2-y1)*(y2-y1)+(z2-z1)*(z2-z1))
if(dist.lt.50) then
	epic_dist = (dist/rz)/per
else
	cosa = x1*x2 + y1*y2 + z1*z2
	epic_dist = ACOS(cosa)/PER
end if

RETURN
END


PROGRAM A5Q2
!--
!Checks if a matrix is a block matrix and returns the sizes of blocks in the matrix
!--
IMPLICIT NONE
REAL, DIMENSION(:,:), ALLOCATABLE :: An
INTEGER, DIMENSION(:), ALLOCATABLE :: Bn
INTEGER :: i, n, check, blocknum

PRINT *, "This program reads a matrix A,determines if it is a block matrix, and if so, returns the sizes of each block."
DO
	PRINT *, "Input the size of A (0 to stop)"
    READ *, n
    IF (n .eq. 0) STOP
    ALLOCATE(An(n, n), Bn(n), STAT=check)
    IF (check .ne. 0) THEN
		PRINT *, "Could not allocate the array A"
    ELSE
		PRINT *, "Please enter matrix A:"
        READ *, (An(i, 1:n), i=1,n)
        PRINT *, "Array A accepted."
        blocknum = Blocks(An, n, Bn)
        IF (blocknum .eq. -1) THEN
			PRINT *, "A is not a block matrix"
		ELSE
			PRINT *, "number of blocks:", blocknum
            PRINT *, "block sizes are:", (Bn(1:blocknum))
		END IF
        DEALLOCATE(An, Bn)

    END IF
END DO

CONTAINS
!- returns -1 if A is not a block matrix
INTEGER FUNCTION Blocks(A,n,B)
REAL, DIMENSION(:,:), INTENT(IN) :: A
INTEGER, DIMENSION(:), INTENT(INOUT) :: B
INTEGER, INTENT(IN) :: n
INTEGER :: i, j, is, js, s, count, bi
LOGICAL :: blkmatrix

!- Innocent until proven guilty
blkmatrix = .true.
count = 0
s = 0
bi = 0
DO i = 1,n
  	!- Consider that if we're not in a block there may be a 0 on the diagonal.
    !- so if there is a 0 continue without stopping unless it should be in a block
    j = i
    ! find the first new element of a new block
  	IF (A(i, j) .ne. 0.0 .and. s.eq. 0) THEN
        s = 0
        !- this is the corner so as we count 'out' from the first element we should get the size of the block
  		DO is = i, n
        	js = is
            IF (A(is, j) .ne. 0 .and. A(i, js) .ne. 0.0) THEN
				s = s + 1
            !- if one is nonzero and the other is not, then this is not symmetrical off the diagonal and therefore not a block matrix
            ELSE IF ((A(is, j) .ne. 0 .or. A(i, js) .ne. 0.0).and.( A(is, j) .eq. 0 .or. A(i, js) .eq. 0.0)) THEN
              	blkmatrix = .false.
            END IF
        END DO
		!- Now we have the supposed size of the block matrix
        !- Check that the matrix matches that size
        count = s
        is = i + 1
        !- go down the digonal until we know we're outside of the block (block's length = s)
        DO is = (i+1), (i+s-1)
			js = is
            IF (js .le. n .and. is .le. n) THEN
				IF ((A(is, j) .ne. 0.0 .or. A(i, js) .ne. 0.0).and.( A(is, j) .eq. 0 .or. A(i, js) .eq. 0.0)) THEN
            		!- again, if one is nonzero and the other is not, then this is not symmetrical off the diagonal and therefore not a block matrix
					blkmatrix = .false.
                END IF
            END IF
        END DO
        !- when we leave the loop we need to realie that s is the size, but is also included in the current i
        !- therefore when we iterate through i s times to get outside of this discovered block, we'll have to decerement s once
        s = s - 1
        !- bi is our index for B but also the count of blocks to be passed back
        bi = bi + 1
		B(bi) = count
    ELSE IF (s .ne. 0) THEN
      	s = s - 1
	END IF
END DO
IF (blkmatrix .and. bi .gt. 0) THEN
  	Blocks = bi
ELSE
  	Blocks = -1
    DO i = 1,n
		B(i) = 0
    END DO
END IF

END FUNCTION Blocks
END PROGRAM A5Q2


MODULE SUB_Quadrature_GL
!!#### PURPOSE
!! Provides Gauss-Legendre quadrature set abcissas
!! and weights on an interval, x.

!!#### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp , KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rdp,ONLY: c_PI                 !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_Sequence                                 !!((03-A-FUN_Sequence.f90))
USE SUB_CLEAR                                    !!((04-A-SUB_CLEAR.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE Quadrature_GL
 MODULE PROCEDURE Quadrature_GL_Rsp
 MODULE PROCEDURE Quadrature_GL_Rdp
ENDINTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: Quadrature_GL

CONTAINS

PURE SUBROUTINE Quadrature_GL_Rsp( abcissas , weights , domain , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_Rdp),PARAMETER :: EPS=3.0e-14_KIND_Rdp  !set the tolerance a little lower than in the
INCLUDE "05-B-SUB_Quadrature_GL.f90.hdr"    !pure double precision procedure below
!!--begin--
INCLUDE "05-B-SUB_Quadrature_GL.f90.bdy"
!!--end--
END SUBROUTINE

PURE SUBROUTINE Quadrature_GL_Rdp( abcissas , weights , domain , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp    !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_Rdp),PARAMETER :: EPS=1.0e-14_KIND_Rdp
INCLUDE "05-B-SUB_Quadrature_GL.f90.hdr"
!!--begin--
INCLUDE "05-B-SUB_Quadrature_GL.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


PROGRAM LA_CHEGVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_HEGVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(4(1X,1H(,F7.3,1H,,F7.3,1H):))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: UPLO
      INTEGER :: I, J, INFO, N
      INTEGER :: IL, IU, ITYPE
      REAL(WP) :: VL, VU
      INTEGER  ::  M
!  .. LOCAL ARRAYS ..
      INTEGER, ALLOCATABLE :: IFAIL(:)
      REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), W(:)
      COMPLEX(WP), ALLOCATABLE :: A(:,:), B(:,:)
!  .. EXECUTABLE STATEMENTS ..
      WRITE(NOUT,*) 'CHEGVX ET_Example Program Results.'
      READ(NIN,*) ! SKIP HEADING IN DATA FILE
      READ(NIN,*) N
      ITYPE = 1; UPLO = 'L'
      VL = -10; VU = 10; IL = 1; IU = N;
      ALLOCATE ( A(N,N), B(N,N), W(N), AA(N,N), BB(N,N), IFAIL(N))
      DO I = 1, N
        READ(NIN,*) (AA(I, J), J = 1, N)
      ENDDO
      DO I = 1, N
        READ(NIN,*) (BB(I, J), J = 1, N)
      ENDDO
      A=AA; B=BB
      WRITE(NOUT,*) 'The matrix A:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      ENDDO
      WRITE(NOUT,*) 'The matrix B:'
      DO I = 1, N
        WRITE(NOUT,FMT) B(I,:)
      ENDDO
!
      WRITE(NOUT,*) '---------------------------------------------------------'
      WRITE(NOUT,*)
      WRITE ( NOUT, * )'Details of LA_CHEGVX LAPACK Subroutine Results.'
      WRITE(NOUT,*)
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_HEGVX(A, B, W, INFO=INFO)'
      WRITE(NOUT,*) 'LA_HEGVX computes all the eigenvalues of a real'
      WRITE(NOUT,*) 'symmetric-definite generalized eigenproblem'
      WRITE(NOUT,*) 'A*x = lambda*B*x'
      WRITE(NOUT,*) 'ON ENTRY: A, B'
      WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
      WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
      WRITE(NOUT,*) 'ON EXIT: A, B, W'
      WRITE(NOUT,*) '   A - destroyed matrix A'
      WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
      WRITE(NOUT,*) '       factorization'
      WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
      A=AA
      B=BB
      CALL LA_HEGVX(A, B, W, INFO=INFO)
      WRITE(NOUT,*) 'The eigenvalues computed by LA_HEGVX:'
      WRITE(NOUT,FMT) W(:)
      WRITE(NOUT,*) 'INFO = ',INFO
!
      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='V', IL=IL, IU=IU, INFO=INFO)"
      WRITE(NOUT,*) 'LA_HEGVX computes all the eigenvalues and eigenvectors'
      WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
      WRITE(NOUT,*) 'A*x = lambda*B*x'
      WRITE(NOUT,*) 'ON ENTRY: A, B'
      WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
      WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
      WRITE(NOUT,*) 'ON EXIT: A, B, W'
      WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
      WRITE(NOUT,*) '       Z**T*B*Z = I'
      WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
      WRITE(NOUT,*) '       factorization'
      WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
      A=AA
      B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='V', IL=IL, IU=IU, INFO=INFO)
      WRITE(NOUT,*) 'The eigenvalues computed by LA_HEGVX: '
      WRITE(NOUT,FMT) W(:)
      WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_HEGVX:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT, *) 'The indices of the smallest eigenvalue to be returned: IL= ', IL
      WRITE(NOUT, *) 'The indices of the largest eigenvalue to be returned: IU= ', IU
      WRITE(NOUT,*) 'The orthonormal eigenvectors of the matrix A '
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) 'INFO = ',INFO
!
      ITYPE=1
      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, ITYPE, 'V', VL=VL, VU=VU, INFO=INFO)"
      WRITE(NOUT,*) 'LA_HEGVX computes all the eigenvalues and eigenvectors'
      WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
      WRITE(NOUT,*) 'A*x = lambda*B*x'
      WRITE(NOUT,*) 'ON ENTRY: A, B'
      WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
      WRITE(NOUT,*) '   B - the original matrix (lower triangular)'
      WRITE(NOUT,*) 'ON EXIT: A, B, W'
      WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
      WRITE(NOUT,*) '       Z**T*B*Z = I'
      WRITE(NOUT,*) '   B - the triangular factor L from the Cholesky'
      WRITE(NOUT,*) '       factorization'
      WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
      A=AA
      B=BB
      CALL LA_HEGVX(A, B, W, ITYPE, 'V', VL=VL, VU=VU, INFO=INFO)
      WRITE(NOUT,*) 'The eigenvalues computed by LA_HEGVX:'
      WRITE(NOUT,FMT) W(:)
      WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_HEGVX:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT, *) 'The lower bound of the interval to be searched for eigenvalues VL= ', VL
      WRITE(NOUT, *) 'The upper bound of the interval to be searched for eigenvalues VU= ', VU
      WRITE(NOUT,*) 'The orthonormal eigenvectors of the matrix A '
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) 'INFO = ',INFO

      ITYPE = 2
      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, ITYPE, 'V',  M=M, IFAIL=IFAIL, INFO=INFO)"
      WRITE(NOUT,*) 'LA_HEGVX computes all the eigenvalues and eigenvectors'
      WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
      WRITE(NOUT,*) 'A*B*x = lambda*x'
      WRITE(NOUT,*) 'ON ENTRY: A, B'
      WRITE(NOUT,*) '   A - the original matrix (lower triangular)'
      WRITE(NOUT,*) '   B - the original matrix (lower triangular)'
      WRITE(NOUT,*) 'ON EXIT: A, B, W'
      WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
      WRITE(NOUT,*) '       Z**T*B*Z = I'
      WRITE(NOUT,*) '   B - the triangular factor L from the Cholesky'
      WRITE(NOUT,*) '       factorization'
      WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
      A=AA
      B=BB
      CALL LA_HEGVX(A, B, W, ITYPE, 'V', M=M, IFAIL=IFAIL, INFO=INFO)
      WRITE(NOUT,*) 'The eigenvalues computed by LA_HEGVX:'
      WRITE(NOUT,FMT) W(:)
      WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_HEGVX:'
      DO I = 1, N
      WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) ' IFAIL  computed by LA_HEGVX:'
      WRITE(NOUT, *) IFAIL(:)
      WRITE(NOUT, *) 'The total number of eigenvalues found ', M
      WRITE(NOUT,*) 'The orthonormal eigenvectors of the matrix A'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) 'INFO = ',INFO

      ITYPE = 3
      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, ITYPE, 'V', 'L', VL, VU, M=M, IFAIL=IFAIL, INFO=INFO)"
      WRITE(NOUT,*) 'LA_HEGVX computes all the eigenvalues and eigenvectors'
      WRITE(NOUT,*) 'of a real symmetric-definite generalized eigenproblem'
      WRITE(NOUT,*) 'B*A*x = lambda*x'
      WRITE(NOUT,*) 'ON ENTRY: A, B'
      WRITE(NOUT,*) '   A - the original matrix (upper triangular)'
      WRITE(NOUT,*) '   B - the original matrix (upper triangular)'
      WRITE(NOUT,*) 'ON EXIT: A, B, W'
      WRITE(NOUT,*) '   A - the eigenvectors normalized as follows:'
      WRITE(NOUT,*) '       Z**T*inv(B)*Z = I'
      WRITE(NOUT,*) '   B - the triangular factor U from the Cholesky'
      WRITE(NOUT,*) '       factorization'
      WRITE(NOUT,*) '   W - the eigenvalues in ascending order'
      A=AA
      B=BB
      UPLO='L'
      CALL LA_HEGVX(A, B, W, ITYPE,'V','L', VL, VU, M=M, IFAIL=IFAIL, INFO=INFO)
      WRITE(NOUT,*) 'The eigenvalues computed by LA_HEGVX:'
      WRITE(NOUT,FMT) W(:)
      WRITE(NOUT,*) 'The normalized eigenvectors computed by LA_HEGVX:'
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) ' IFAIL  computed by LA_HEGVX:'
      WRITE(NOUT, *) IFAIL(:)
      WRITE(NOUT, *) 'The total number of eigenvalues found ', M
      WRITE(NOUT, *) 'The lower bound of the interval to be searched for eigenvalues VL= ', VL
      WRITE(NOUT, *) 'The upper bound of the interval to be searched for eigenvalues VU= ', VU
      WRITE(NOUT,*) 'The orthonormal eigenvectors of the matrix A '
      DO I = 1, N
        WRITE(NOUT,FMT) A(I,:)
      END DO
      WRITE(NOUT,*) 'INFO = ',INFO

! STARTING ERROR TESTS
      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A(1:N-1,1:N), B, W, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A(1:N-1,1:N), B, W, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B(1:N,1:N-1), W, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B(1:N,1:N-1), W, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W(1:N-2), INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W(1:N-2), INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, 5, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, 5, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='T', INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='T', INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, UPLO='T', INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, UPLO='T', INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='V', VL=10.0, VU=2.0, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='V', VL=10.0, VU=2.0, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='V', VL=1.0, VU=10.0, IL=1, IU=3, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='V', VL=1.0, VU=10.0, IL=1, IU=3, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='V', IL=100, IU=3, INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='V', IL=100, IU=3, INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

      WRITE(NOUT,*)
      WRITE(NOUT,*) "CALL LA_HEGVX(A, B, W, JOBZ='V', IFAIL=IFAIL(1:N-3), INFO=INFO)"
      A=AA; B=BB
      CALL LA_HEGVX(A, B, W, JOBZ='V', IFAIL=IFAIL(1:N-3), INFO=INFO)
      WRITE(NOUT,*) 'INFO = ',INFO

END PROGRAM LA_CHEGVX_ET_EXAMPLE


c
c     Computation of spherical Bessel functions via recurrence
c
c**********************************************************************
      subroutine besseljs3d(nterms,z,scale,fjs,ifder,fjder)
c**********************************************************************
c
c PURPOSE:
c
c	This subroutine evaluates the first NTERMS spherical Bessel
c	functions and if required, their derivatives.
c	It incorporates a scaling parameter SCALE so that
c
c		fjs_n(z)=j_n(z)/SCALE^n
c		fjder_n(z)=\frac{\partial fjs_n(z)}{\partial z}
c
c INPUT:
c
c    nterms (integer): order of expansion of output array fjs
c    z     (complex *16): argument of the spherical Bessel functions
c    scale    (real *8) : scaling factor (discussed above)
c    ifder  (integer): flag indicating whether to calculate "fjder"
c		          0	NO
c		          1	YES
c OUTPUT:
c    fjs   (complex *16): array of scaled Bessel functions.
c    fjder (complex *16): array of derivs of scaled Bessel functions.
c
c
      implicit none
      integer ier,nterms,ifder,lwfjs,ntop,i,ncntr
      real *8 scale,d0,d1,dc1,dc2,dcoef,dd,done,tiny,zero
      real *8 scalinv,sctot,upbound,upbound2,upbound2inv
      integer, allocatable :: iscale(:)
      complex *16, allocatable :: fjtmp(:)
      complex *16 wavek,fjs(0:nterms),fjder(0:*)
      complex *16 z,zinv,com,fjm1,fj0,fj1,zscale,ztmp
c
      data upbound/1.0d+32/, upbound2/1.0d+40/, upbound2inv/1.0d-40/
      data tiny/1.0d-200/,done/1.0d0/,zero/0.0d0/
c
c ... Initializing ...
c
      ier=0
c
c       set to asymptotic values if argument is sufficiently small
c
      if (abs(z).lt.tiny) then
        fjs(0) = done
        do i = 1, nterms
          fjs(i) = zero
	    enddo
c
	    if (ifder.eq.1) then
	      do i=0,nterms
	        fjder(i)=zero
	      enddo
          fjder(1)=done/(3*scale)
        endif
        return
      endif
c
c ... Step 1: recursion up to find ntop, starting from nterms
c
      zinv=done/z

      fjm1 = zero
      fj0 = done

c
cc     note max point for upward recurrence is
c      hard coded to nterms + 1000,
c      this might cause loss of accuracy for some
c      arguments in the complex plane for large
c      nterms. For example, it is a terrible idea
c      to use this code for z>>nterms^2

      lwfjs = nterms + 10000
      ntop=lwfjs
c
      do i=nterms,lwfjs
        dcoef=2*i+done
        fj1=dcoef*zinv*fj0-fjm1
        dd = abs(fj1)**2
        if(dd .gt. upbound2) then
          ntop=i+1
          goto 1300
        endif
        fjm1 = fj0
        fj0 = fj1
      enddo
 1300 continue

cc      call prinf('ntop=*',ntop,1)

      allocate(iscale(0:ntop),fjtmp(0:ntop))
c
c ... Step 2: Recursion back down to generate the unscaled jfuns:
c             if magnitude exceeds UPBOUND2, rescale and continue the
c	      recursion (saving the order at which rescaling occurred
c	      in array iscale.
c
      do i=0,ntop
         iscale(i)=0
      enddo
c
      fjtmp(ntop)=zero
      fjtmp(ntop-1)=done
      do i=ntop-1,1,-1
        dcoef=2*i+done
        fjtmp(i-1)=dcoef*zinv*fjtmp(i)-fjtmp(i+1)
        dd = abs(fjtmp(i-1))**2
        if (dd.gt.UPBOUND2) then
          fjtmp(i) = fjtmp(i)*UPBOUND2inv
          fjtmp(i-1) = fjtmp(i-1)*UPBOUND2inv
          iscale(i) = 1
        endif
      enddo
c
c ...  Step 3: go back up to the top and make sure that all
c              Bessel functions are scaled by the same factor
c              (i.e. the net total of times rescaling was invoked
c              on the way down in the previous loop).
c              At the same time, add scaling to fjs array.
c
      ncntr=0
      scalinv=done/scale
      sctot = 1.0d0
      do i=1,ntop
         sctot = sctot*scalinv
         if(iscale(i-1).eq.1) sctot=sctot*UPBOUND2inv
         fjtmp(i)=fjtmp(i)*sctot
      enddo
c
c ... Determine the normalization parameter:
c
      fj0=sin(z)*zinv
      fj1=fj0*zinv-cos(z)*zinv
c
      d0=abs(fj0)
      d1=abs(fj1)
      if (d1 .gt. d0) then
         zscale=fj1/(fjtmp(1)*scale)
      else
         zscale=fj0/fjtmp(0)
      endif
c
c ... Scale the jfuns by zscale:
c
      ztmp=zscale
      do i=0,nterms
         fjs(i)=fjtmp(i)*ztmp
      enddo
c
c ... Finally, calculate the derivatives if desired:
c
      if (ifder.eq.1) then
        fjder(0)=-fjs(1)*scale
        do i=1,nterms
          dc1=i/(2*i+done)
          dc2=done-dc1
          dc1=dc1*scalinv
          dc2=dc2*scale
          fjder(i)=(dc1*fjtmp(i-1)-dc2*fjtmp(i+1))*ztmp
        enddo
      endif
      return
      end
c


module merge_sort_int32
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: merge_sort
contains
    subroutine merge_sort(ar)
        integer(int32),intent(inout):: ar(:)
        integer(int32):: i,n,d,hd,tmp(size(ar))

        n = size(ar)
        do i=1,n-1,2
            if (ar(i+1) < ar(i)) call swap(ar(i), ar(i+1))
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar(i:i+d-1), tmp, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar(i:), tmp, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar, tmp, n1, i2, n2)
        integer(int32),intent(inout):: ar(:), tmp(:)
        integer(int32),value:: n1, i2, n2
        integer(int32):: i,i1

        i1=1
        tmp(i1:n1) = ar(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar(i:)=tmp(i1:n1)
                return
            else
                if (ar(i2) <= tmp(i1)) then
                    ar(i) = ar(i2); i2=i2+1
                else
                    ar(i) = tmp(i1); i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap(x, y)
        integer(int32),intent(inout):: x, y
        integer(int32):: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine
end module

module merge_sort_int64
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: merge_sort
contains
    subroutine merge_sort(ar)
        integer(int64),intent(inout):: ar(:)
        integer(int64):: i,n,d,hd,tmp(size(ar))

        n = size(ar)
        do i=1,n-1,2
            if (ar(i+1) < ar(i)) call swap(ar(i), ar(i+1))
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar(i:i+d-1), tmp, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar(i:), tmp, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar, tmp, n1, i2, n2)
        integer(int64),intent(inout):: ar(:), tmp(:)
        integer(int64),value:: n1, i2, n2
        integer(int64):: i,i1

        i1=1
        tmp(i1:n1) = ar(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar(i:)=tmp(i1:n1)
                return
            else
                if (ar(i2) <= tmp(i1)) then
                    ar(i) = ar(i2); i2=i2+1
                else
                    ar(i) = tmp(i1); i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap(x, y)
        integer(int64),intent(inout):: x, y
        integer(int64):: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine
end module

module merge_sort_char
    use,intrinsic :: iso_fortran_env
    implicit none
    private
    public:: merge_sort
contains
    subroutine merge_sort(ar)
        character(*),intent(inout):: ar(:)
        character(:),allocatable:: tmp(:)
        integer(int32):: i,n,d,hd

        n = size(ar)
        allocate(tmp, source=ar)
        do i=1,n-1,2
            if (ar(i+1) < ar(i)) call swap(ar(i), ar(i+1))
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar(i:i+d-1), tmp, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar(i:), tmp, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar, tmp, n1, i2, n2)
        character(*),intent(inout):: ar(:), tmp(:)
        integer(int32),value:: n1, i2, n2
        integer(int32):: i,i1

        i1=1
        tmp(i1:n1) = ar(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar(i:)=tmp(i1:n1)
                return
            else
                if (ar(i2) <= tmp(i1)) then
                    ar(i) = ar(i2); i2=i2+1
                else
                    ar(i) = tmp(i1); i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap(x, y)
        character(*),intent(inout):: x, y
        character(:),allocatable:: t1, t2

        allocate(t1, mold=x)
        allocate(t2, mold=y)
        t1 = x
        t2 = y
        x = t2
        y = t1
    end subroutine
end module

module merge_sort_mod
    use,intrinsic :: iso_fortran_env
    use merge_sort_int32, ms32 => merge_sort
    use merge_sort_int64, ms64 => merge_sort
    use merge_sort_char,  msch => merge_sort
    interface merge_sort
        module procedure ms32, ms64, msch
    end interface
end module


C*******************************************************************
C TEST_CGRAD
C To test conjugate gradient routines (contained in "conju_grad.c")
C Calls JLP_CGRAD
C
C We examine the problem: psi = aa phi
C We suppose that the solution is: phi = (x=1;  y=2)
C    1x + 2y = 5.1
C    4x + 5y = 14.5
C   -1x + 2y = 2.9
C   -2x + 1y = 0.1
C
C Version 01-01-1993
C JLP
C*******************************************************************
        program test_cgrad
	double precision aa(2,4),phi(2),psi(4)
	double precision cte
        integer ifail, nx, ny, i ,j
        nx = 2
        ny = 4

C Vector psi:
        psi(1)=5.1
        psi(2)=14.5
        psi(3)=2.9
        psi(4)=0.1

C Matrix
        aa(1,1)=1.
        aa(2,1)=2.
        aa(1,2)=4.
        aa(2,2)=5.
        aa(1,3)=-1.
        aa(2,3)=2.
        aa(1,4)=-2.
        aa(2,4)=1.

C First guess for phi:
        print *,' Enter initial guess (one value only)'
        read(5,*)cte
        do i=1,2
          phi(i)=CTE
        enddo

C
         call jlp_cgrad(aa,psi,phi,nx,ny,ifail)
         print *,' ifail=',ifail

        stop
        end


!   Date of Easter
!   Based on algorithm by Jean Meeus, Astronomical Algorithms, 1998, p. 67

program DateOfEaster
implicit none
    integer :: x, a, b, c, d, e, f, g, h, i, k, l, m, n, p, z

10  print *,'Enter year:'
    read *, x

    if (x < 1583) then
        print *,'Year earlier than 1583 is not allowed!'
        go to 10
    endif

    a = mod(x, 19)
    b = x / 100
    c = mod(x, 100)
    d = b /4
    e = mod(b, 4)
    f = (b + 8) / 25;
    g = (b - f + 1) /3;
    h = mod(19 * a + b - d - g + 15, 30)
    i = c / 4
    k = mod(c, 4)
    l = mod(32 + 2 * e + 2 * i - h - k, 7)
    m = (a + 11 * h + 22 * l) / 451
    z = h + l - 7 * m + 114
    n = z / 31
    p = mod(z, 31) + 1

    if (n == 3 .or. n == 4) then
        if (n == 3) then
            print *, "March ", p
        else
            print *, "April ", p
        endif
    endif

end program DateOfEaster