      SUBROUTINE SB02RU( DICO, HINV, TRANA, UPLO, N, A, LDA, G, LDG, Q,
     $                   LDQ, S, LDS, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct the 2n-by-2n Hamiltonian or symplectic matrix S
C     associated to the linear-quadratic optimization problem, used to
C     solve the continuous- or discrete-time algebraic Riccati equation,
C     respectively.
C
C     For a continuous-time problem, S is defined by
C
C             ( op(A)   -G    )
C         S = (               ),                                     (1)
C             (  -Q   -op(A)' )
C
C     and for a discrete-time problem by
C
C                     -1              -1
C             (  op(A)           op(A)  *G       )
C         S = (        -1                   -1   ),                  (2)
C             ( Q*op(A)     op(A)' + Q*op(A)  *G )
C
C     or
C                              -T             -T
C             ( op(A) + G*op(A)  *Q   -G*op(A)   )
C         S = (           -T                 -T  ),                  (3)
C             (     -op(A)  *Q          op(A)    )
C
C     where op(A) = A or A' (A**T), A, G, and Q are n-by-n matrices,
C     with G and Q symmetric. Matrix A must be nonsingular in the
C     discrete-time case.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  Continuous-time system;
C             = 'D':  Discrete-time system.
C
C     HINV    CHARACTER*1
C             If DICO = 'D', specifies which of the matrices (2) or (3)
C             is constructed, as follows:
C             = 'D':  The matrix S in (2) is constructed;
C             = 'I':  The (inverse) matrix S in (3) is constructed.
C             HINV is not referenced if DICO = 'C'.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices G and Q is
C             stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, and Q.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     G       (input/output) DOUBLE PRECISION array, dimension (LDG,N)
C             On entry, the leading N-by-N upper triangular part (if
C             UPLO = 'U') or lower triangular part (if UPLO = 'L') of
C             this array must contain the upper triangular part or lower
C             triangular part, respectively, of the symmetric matrix G.
C             On exit, if DICO = 'D', the leading N-by-N part of this
C             array contains the symmetric matrix G fully stored.
C             If DICO = 'C', this array is not modified on exit, and the
C             strictly lower triangular part (if UPLO = 'U') or strictly
C             upper triangular part (if UPLO = 'L') is not referenced.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, the leading N-by-N upper triangular part (if
C             UPLO = 'U') or lower triangular part (if UPLO = 'L') of
C             this array must contain the upper triangular part or lower
C             triangular part, respectively, of the symmetric matrix Q.
C             On exit, if DICO = 'D', the leading N-by-N part of this
C             array contains the symmetric matrix Q fully stored.
C             If DICO = 'C', this array is not modified on exit, and the
C             strictly lower triangular part (if UPLO = 'U') or strictly
C             upper triangular part (if UPLO = 'L') is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
C             If INFO = 0, the leading 2N-by-2N part of this array
C             contains the Hamiltonian or symplectic matrix of the
C             problem.
C
C     LDS     INTEGER
C             The leading dimension of the array S.  LDS >= MAX(1,2*N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK >= 0,   if DICO = 'C';
C             LIWORK >= 2*N, if DICO = 'D'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if DICO = 'D', DWORK(1) returns the reciprocal
C             condition number  RCOND  of the given matrix  A,  and
C             DWORK(2) returns the reciprocal pivot growth factor
C             norm(A)/norm(U) (see SLICOT Library routine MB02PD).
C             If DWORK(2) is much less than 1, then the computed  S
C             and  RCOND  could be unreliable. If 0 < INFO <= N, then
C             DWORK(2) contains the reciprocal pivot growth factor for
C             the leading INFO columns of  A.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 0,          if DICO = 'C';
C             LDWORK >= MAX(2,6*N), if DICO = 'D'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  if the leading i-by-i (1 <= i <= N) upper triangular
C                   submatrix of A is singular in discrete-time case;
C             = N+1:  if matrix A is numerically singular in discrete-
C                   time case.
C
C     METHOD
C
C     For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1)
C     is constructed.
C     For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or
C     (3) - the inverse of the matrix in (2) - is constructed.
C
C     NUMERICAL ASPECTS
C
C     The discrete-time case needs the inverse of the matrix A, hence
C     the routine should not be used when A is ill-conditioned.
C                               3
C     The algorithm requires 0(n ) floating point operations in the
C     discrete-time case.
C
C     FURTHER COMMENTS
C
C     This routine is a functionally extended and with improved accuracy
C     version of the SLICOT Library routine SB02MU. Transposed problems
C     can be dealt with as well. The LU factorization of  op(A)  (with
C     no equilibration) and iterative refinement are used for solving
C     the various linear algebraic systems involved.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, HINV, TRANA, UPLO
      INTEGER           INFO, LDA, LDG, LDQ, LDS, LDWORK, N
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*),
     $                  S(LDS,*)
C     .. Local Scalars ..
      CHARACTER         EQUED, TRANAT
      LOGICAL           DISCR, LHINV, LUPLO, NOTRNA
      INTEGER           I, J, N2, NJ, NP1
      DOUBLE PRECISION  PIVOTG, RCOND, RCONDA, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DLACPY, DLASET, DSWAP, MA02AD,
     $                  MA02ED, MB02PD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      N2 = N + N
      INFO = 0
      DISCR  = LSAME( DICO,  'D' )
      LUPLO  = LSAME( UPLO,  'U' )
      NOTRNA = LSAME( TRANA, 'N' )
      IF( DISCR )
     $   LHINV = LSAME( HINV, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN
         INFO = -1
      ELSE IF( DISCR ) THEN
         IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) )
     $      INFO = -2
      ELSE IF( INFO.EQ.0 ) THEN
         IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' )
     $                   .AND. .NOT.LSAME( TRANA, 'C' ) ) THEN
            INFO = -3
         ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
            INFO = -4
         ELSE IF( N.LT.0 ) THEN
            INFO = -5
         ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
            INFO = -7
         ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
            INFO = -9
         ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
            INFO = -11
         ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN
            INFO = -13
         ELSE IF( ( LDWORK.LT.0 ) .OR.
     $            ( DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) ) THEN
            INFO = -16
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02RU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( DISCR ) THEN
            DWORK(1) = ONE
            DWORK(2) = ONE
         END IF
         RETURN
      END IF
C
C     The code tries to exploit data locality as much as possible,
C     assuming that LDS is greater than LDA, LDQ, and/or LDG.
C
      IF ( .NOT.DISCR ) THEN
C
C        Continuous-time case: Construct Hamiltonian matrix column-wise.
C
C        Copy op(A) in S(1:N,1:N), and construct full Q
C        in S(N+1:2*N,1:N) and change the sign.
C
         DO 100 J = 1, N
            IF ( NOTRNA ) THEN
               CALL DCOPY( N, A(1,J), 1, S(1,J), 1 )
            ELSE
               CALL DCOPY( N, A(J,1), LDA, S(1,J), 1 )
            END IF
C
            IF ( LUPLO ) THEN
C
               DO 20 I = 1, J
                  S(N+I,J) = -Q(I,J)
   20          CONTINUE
C
               DO 40 I = J + 1, N
                  S(N+I,J) = -Q(J,I)
   40          CONTINUE
C
            ELSE
C
               DO 60 I = 1, J - 1
                  S(N+I,J) = -Q(J,I)
   60          CONTINUE
C
               DO 80 I = J, N
                  S(N+I,J) = -Q(I,J)
   80          CONTINUE
C
            END IF
  100    CONTINUE
C
C        Construct full G in S(1:N,N+1:2*N) and change the sign, and
C        construct -op(A)' in S(N+1:2*N,N+1:2*N).
C
         DO 240 J = 1, N
            NJ = N + J
            IF ( LUPLO ) THEN
C
               DO 120 I = 1, J
                  S(I,NJ) = -G(I,J)
  120          CONTINUE
C
               DO 140 I = J + 1, N
                  S(I,NJ) = -G(J,I)
  140          CONTINUE
C
            ELSE
C
               DO 160 I = 1, J - 1
                  S(I,NJ) = -G(J,I)
  160          CONTINUE
C
               DO 180 I = J, N
                  S(I,NJ) = -G(I,J)
  180          CONTINUE
C
            END IF
C
            IF ( NOTRNA ) THEN
C
               DO 200 I = 1, N
                  S(N+I,NJ) = -A(J,I)
  200          CONTINUE
C
            ELSE
C
               DO 220 I = 1, N
                  S(N+I,NJ) = -A(I,J)
  220          CONTINUE
C
            END IF
  240    CONTINUE
C
      ELSE
C
C        Discrete-time case: Construct the symplectic matrix (2) or (3).
C
C        Fill in the remaining triangles of the symmetric matrices Q
C        and G.
C
         CALL MA02ED( UPLO, N, Q, LDQ )
         CALL MA02ED( UPLO, N, G, LDG )
C
C        Prepare the construction of S in (2) or (3).
C
         NP1 = N + 1
         IF ( NOTRNA ) THEN
            TRANAT = 'T'
         ELSE
            TRANAT = 'N'
         END IF
C
C        Solve  op(A)'*X = Q  in  S(N+1:2*N,1:N),  using the LU
C        factorization of  op(A),  obtained in  S(1:N,1:N),  and
C        iterative refinement. No equilibration of  A  is used.
C        Workspace:  6*N.
C
         CALL MB02PD( 'No equilibration', TRANAT, N, N, A, LDA, S,
     $                LDS, IWORK, EQUED, DWORK, DWORK, Q, LDQ,
     $                S(NP1,1), LDS, RCOND, DWORK, DWORK(NP1),
     $                IWORK(NP1), DWORK(N2+1), INFO )
C
C        Return if the matrix is exactly singular or singular to
C        working precision.
C
         IF( INFO.GT.0 ) THEN
            DWORK(1) = RCOND
            DWORK(2) = DWORK(N2+1)
            RETURN
         END IF
C
         RCONDA = RCOND
         PIVOTG = DWORK(N2+1)
C
         IF ( LHINV ) THEN
C
C           Complete the construction of S in (2).
C
C           Transpose  X  in-situ.
C
            DO 260 J = 1, N - 1
               CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS )
  260       CONTINUE
C
C           Solve  op(A)*X = I_n  in  S(N+1:2*N,N+1:2*N),  using the LU
C           factorization of  op(A),  computed in  S(1:N,1:N),  and
C           iterative refinement.
C
            CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS )
            CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK,
     $                   EQUED, DWORK, DWORK, S(1,NP1), LDS, S(NP1,NP1),
     $                   LDS, RCOND, DWORK, DWORK(NP1), IWORK(NP1),
     $                   DWORK(N2+1), INFO )
C
C           Solve  op(A)*X = G  in  S(1:N,N+1:2*N),  using the LU
C           factorization of  op(A),  computed in  S(1:N,1:N),  and
C           iterative refinement.
C
            CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK,
     $                   EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS,
     $                   RCOND, DWORK, DWORK(NP1), IWORK(NP1),
     $                   DWORK(N2+1), INFO )
C
C                      -1
C           Copy  op(A)    from  S(N+1:2*N,N+1:2*N)  in  S(1:N,1:N).
C
            CALL DLACPY( 'Full', N, N, S(NP1,NP1), LDS, S, LDS )
C
C                                    -1
C           Compute  op(A)' + Q*op(A)  *G  in  S(N+1:2*N,N+1:2*N).
C
            IF ( NOTRNA ) THEN
               CALL MA02AD( 'Full', N, N, A, LDA, S(NP1,NP1), LDS )
            ELSE
               CALL DLACPY( 'Full', N, N, A, LDA, S(NP1,NP1), LDS )
            END IF
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                  Q, LDQ, S(1,NP1), LDS, ONE, S(NP1,NP1), LDS )
C
         ELSE
C
C           Complete the construction of S in (3).
C
C           Change the sign of  X.
C
            DO 300 J = 1, N
C
               DO 280 I = NP1, N2
                  S(I,J) = -S(I,J)
  280          CONTINUE
C
  300       CONTINUE
C
C           Solve  op(A)'*X = I_n  in  S(N+1:2*N,N+1:2*N),  using the LU
C           factorization of  op(A),  computed in  S(1:N,1:N),  and
C           iterative refinement.
C
            CALL DLASET( 'Full', N, N, ZERO, ONE, S(1,NP1), LDS )
            CALL MB02PD( 'Factored', TRANAT, N, N, A, LDA, S, LDS,
     $                   IWORK, EQUED, DWORK, DWORK, S(1,NP1), LDS,
     $                   S(NP1,NP1), LDS, RCOND, DWORK, DWORK(NP1),
     $                   IWORK(NP1), DWORK(N2+1), INFO )
C
C           Solve  op(A)*X' = -G  in  S(1:N,N+1:2*N),  using the LU
C           factorization of  op(A),  obtained in  S(1:N,1:N),  and
C           iterative refinement.
C
            CALL MB02PD( 'Factored', TRANA, N, N, A, LDA, S, LDS, IWORK,
     $                   EQUED, DWORK, DWORK, G, LDG, S(1,NP1), LDS,
     $                   RCOND, DWORK, DWORK(NP1), IWORK(NP1),
     $                   DWORK(N2+1), INFO )
C
C           Change the sign of  X  and transpose it in-situ.
C
            DO 340 J = NP1, N2
C
               DO 320 I = 1, N
                  TEMP   = -S(I,J)
                  S(I,J) = -S(J-N,I+N)
                  S(J-N,I+N) = TEMP
  320          CONTINUE
C
  340       CONTINUE
C                                   -T
C           Compute  op(A) + G*op(A)  *Q  in  S(1:N,1:N).
C
            IF ( NOTRNA ) THEN
               CALL DLACPY( 'Full', N, N, A, LDA, S, LDS )
            ELSE
               CALL MA02AD( 'Full', N, N, A, LDA, S, LDS )
            END IF
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, -ONE,
     $                  G, LDG, S(NP1,1), LDS, ONE, S, LDS )
C
         END IF
         DWORK(1) = RCONDA
         DWORK(2) = PIVOTG
      END IF
      RETURN
C
C *** Last line of SB02RU ***
      END


program P2
  implicit none
  real :: x1,y1,z1,x2,y2,z2
  print *,'input the first point'
  read *,x1,y1,z1
  print *,'input the second point'
  read *,x2,y2,z2
  print *,'distance is',sqrt((x1-x2)**2+(y1-y2)**2+(z1-z2)**2)

end program P2


program ab
implicit none

integer, parameter :: dp = SELECTED_REAL_KIND(15)
integer :: n, lwork, lda, i, j, info
real(dp), dimension(3,3) :: inert
real(dp), dimension(3) :: w
character :: jobz, uplo
real(dp), allocatable, dimension(:,:) :: work

n = 3

inert(1,1) = 4
inert(1,2) = 5
    inert(2,1) = inert(1,2)
inert(1,3) = 8
    inert(3,1) = inert(1,3)
inert(2,2) = 1
inert(2,3) = 6
    inert(3,2) = inert(2,3)
inert(3,3) = 9

do i = 1, n
    do j = 1, n
        write(*,*) 'inert', i, j, inert(i,j)
    end do
end do

lda = 3
jobz = 'V'
uplo = 'L'
lwork = 102

allocate (work(1,102))

call DSYEV(jobz, uplo, n, inert, lda, w, work, lwork, info)

write(*,*) 'lwork', work(1,1)
write(*,*) 'info', info

write(*,*) 'eigenvalues', w

do i = 1, 3
    do j = 1, 3
        write(*,*) 'eigenvec', 'i', i, 'j', j, inert(i,j)
    end do
end do

end program ab


      PROGRAM xsvdcmp
C     driver for routine svdcmp
      INTEGER MP,NP
      PARAMETER(MP=20,NP=20)
      INTEGER j,k,l,m,n
      REAL a(MP,NP),u(MP,NP),w(NP),v(NP,NP)
      CHARACTER dummy*3
      open(7,file='MATRX3.DAT',status='old')
10    read(7,'(a)') dummy
      if (dummy.eq.'END') goto 99
      read(7,*)
      read(7,*) m,n
      read(7,*)
C     copy original matrix into u
      do 12 k=1,m
        read(7,*) (a(k,l), l=1,n)
        do 11 l=1,n
          u(k,l)=a(k,l)
11      continue
12    continue
C     perform decomposition
      call svdcmp(u,m,n,MP,NP,w,v)
C     print results
      write(*,*) 'Decomposition Matrices:'
      write(*,*) 'Matrix U'
      do 13 k=1,m
        write(*,'(1x,6f12.6)') (u(k,l),l=1,n)
13    continue
      write(*,*) 'Diagonal of Matrix W'
      write(*,'(1x,6f12.6)') (w(k),k=1,n)
      write(*,*) 'Matrix V-Transpose'
      do 14 k=1,n
        write(*,'(1x,6f12.6)') (v(l,k),l=1,n)
14    continue
      write(*,*) 'Check product against original matrix:'
      write(*,*) 'Original Matrix:'
      do 15 k=1,m
        write(*,'(1x,6f12.6)') (a(k,l),l=1,n)
15    continue
      write(*,*) 'Product U*W*(V-Transpose):'
      do 18 k=1,m
        do 17 l=1,n
          a(k,l)=0.0
          do 16 j=1,n
            a(k,l)=a(k,l)+u(k,j)*w(j)*v(l,j)
16        continue
17      continue
        write(*,'(1x,6f12.6)') (a(k,l),l=1,n)
18    continue
      write(*,*) '***********************************'
      write(*,*) 'Press RETURN for next problem'
      read(*,*)
      goto 10
99    close(7)
      END

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


program mandelarea

use aplot

implicit none

type(aplot_t)::p

real, dimension(:), allocatable :: x !x-axis
real, dimension(:), allocatable :: inside    !notinmset counter
real, dimension(:), allocatable :: outside   !inmset counter

real    :: r, i !real & imaginary to create a random complex
complex :: z    !the random complex to be initialized
integer :: b, j ! loop stuff

integer :: currentiter = 0
integer, parameter :: startiter = 100            !start at iteration startiter
integer, parameter :: iterstep = 100           !add(or mult by) iterstep at each batch
integer, parameter :: batch = 100               !number of point on x-axis
integer, parameter :: loopmax = 100000          !montecarlo loop

ALLOCATE(x(batch))
ALLOCATE(inside(batch))
ALLOCATE(outside(batch))

x = 0
inside = 0
outside = 0
currentiter =  startiter

DO b = 1, batch
    x(b) = b - 1
end do

DO b = 1, batch
    !x(b) = real(currentiter)
    !$OMP PARALLEL DO DEFAULT(NONE) SHARED(inside, outside,b,currentiter) private(z,r,i,x)
    DO j = 1, loopmax
        call random_number(r)
        call random_number(i)
        !z = CMPLX(r*2.5-2, i*2.6-1.3)
        z = CMPLX(r*4.0-2.0, i*4.0-2.0)

        do while(abs(z) .GT. 2.0)
            call random_number(r)
            call random_number(i)
            z = CMPLX(r*4.0-2.0, i*4.0-2.0)
        end do

        if(isInMSet(z, currentiter)) then
            !$omp atomic update
            inside(b) = inside(b) + 1
!        else
!            !!$omp atomic update
!            outside(b) = outside(b) + 1
        end if
    end do
    !$OMP END PARALLEL DO
    print *, b, currentiter, inside(b), loopmax - inside(b), (inside(b) / (loopmax - inside(b)) * 100.0)
    currentiter = currentiter + iterstep
end do

print *, "average : ", sum((inside / (loopmax - inside) * 100.0) / batch)

p = initialize_plot()
call add_dataset(p, x, (inside / (loopmax - inside)) * 100.0)
!call add_dataset(p, x, (inside / (loopmax)) * 100.0)
!call set_yscale(p,9.0,12.0)
!call set_xscale(p,real(startiter), real(currentiter))
!call set_xlogarithmic (p,2.0)
call set_xlabel(p, "iteration")
call set_ylabel(p, "area ratio")
call set_title(p, "Mandelbrot area")
call set_serieslabel(p, 0, "Mandelbrot area")
call set_seriestype(p, 0, APLOT_STYLE_DOT)
call display_plot(p)
call destroy_plot(p)

DEALLOCATE(x)
DEALLOCATE(inside)
DEALLOCATE(outside)

CONTAINS

pure function isInMSet(c, maxiter)

    complex, intent(in) :: c
    integer, intent(in) :: maxiter
    integer :: n
    complex :: z
    logical :: isInMSet

    z = CMPLX(0,0)
    n = 0
    IF(((ABS(c - CMPLX(-1,0))) < 0.25) .OR. ((ABS(1.0 - SQRT(1-(4*c)))) < 1.0)) THEN
        isInMSet = .TRUE.
    END IF

    DO WHILE(ABS(z) < 4 .AND. (n < maxiter))
        z = z*z+c
        n = n+1
    END do

    if(n >= maxiter) then
        isInMSet = .TRUE.
    else
        isInMset = .FALSE.
    end if

end function isInMSet

end program mandelarea


!==============================================================================
!!
!> @anchor  slam_math
!!
!> @brief   Contains math constants and basic functions
!!
!> @details The following math functions are available:
!!
!!   angle                       - compute angle between two vectors
!!   copy_matrix                 - copy a matrix (3x3)
!!   copy_vector                 - copy a vector (3)
!!   cross                       - cross product of two vectors
!!   cubic                       - solve cubic function
!!   dot                         - dot product of two vectors
!!   factorial                   - compute factorial of given integer
!!   get_extrema                 - returns extreme values for a given discrete signal (array)
!!   identity_matrix             - returns identity matrix (3x3)
!!   mag                         - magnitude of two vectors
!!   rot1                        - rotation of vector wrt. x-axis
!!   rot2                        - rotation of vector wrt. y-axis
!!   rot3                        - rotation of vector wrt. z-axis
!!   rot1_matrix                 - rotation of matrix wrt. x-axis
!!   rot2_matrix                 - rotation of matrix wrt. y-axis
!!   rot3_matrix                 - rotation of matrix wrt. z-axis
!!
!> @author  Vitali Braun (VB)
!> @author  Christopher Kebschull (ChK)
!!
!> @date

!!
VB:  26.06.2014 (added Doxygen comments)

!!
VB:  21.04.2015 (added 'get_extrema' function)

!!
ChK: 13.10.2019 (Enforcing camel case and adding copyright)

!!

!!
!> @copyright Institute of Space Systems / TU Braunschweig
!------------------------------------------------------------------------
module slam_math

  use slam_error_handling
  use slam_strings
  use slam_types

  implicit none

  real(dp), parameter :: eps20 = 1.d-20
  real(dp), parameter :: eps15 = 1.d-15
  real(dp), parameter :: eps9  = 1.d-9
  real(dp), parameter :: eps6  = 1.d-6
  real(dp), parameter :: eps3  = 1.d-3

  real(dp), parameter :: pi      = 4.d0*atan(1.d0)    ! pi
  real(dp), parameter :: halfPi  = 0.5d0*pi           ! pi/2
  real(dp), parameter :: twoPi   = pi + pi            ! 2pi
  real(dp), parameter :: rad2deg = 180.d0/pi          ! radians to degrees
  real(dp), parameter :: deg2rad = pi/180.d0          ! degrees to radians

  real(dp), parameter :: as2rad       = deg2rad/3.6d3 ! arcseconds to radians
  real(dp), parameter :: as_in_circle = 1296.d3       ! arcseconds in full circle
  real(dp), parameter :: mas2rad      = as2rad*1.d-6  ! microarcseconds to radians
  real(dp), parameter :: infinite     = 999999.9d0
  real(dp), parameter :: undefined    = 999999.1d0

  real(dp), dimension(3), parameter :: uvec1 = (/1.d0,0.d0,0.d0/)
  real(dp), dimension(3), parameter :: uvec2 = (/0.d0,1.d0,0.d0/)
  real(dp), dimension(3), parameter :: uvec3 = (/0.d0,0.d0,1.d0/) ! definition of three unity vectors

contains

!========================================================================
!!
!>  @brief       Angle between two vectors
!!
!>  @param[in]   vec1
!>  @param[in]   vec2
!>  @param[out]  Theta the angle between the two input vectors
!!
!> @date

!!
ChK: 13.10.2019 (replaced eps9**2 with epsilon(1.d0))

!!

!!
!>  @anchor      angle
!!
!----------------------------------------------------
  subroutine angle(       &
                    vec1, & ! <-- DBL() first vector
                    vec2, & ! <-- DBL() second vector
                    theta & ! --> DBL   angle in rad, the output is set to 999999.1D0
                  )         !           to indicate an undefined value. Be SURE to check
                            !           this at the output phase.

    real(dp), dimension(3), intent(in) :: vec1
    real(dp), dimension(3), intent(in) :: vec2

    real(dp), intent(out) :: theta

    real(dp) :: mag_vec1
    real(dp) :: mag_vec2
    real(dp) :: temp

    mag_vec1 = mag(vec1)
    mag_vec2 = mag(vec2)

    if( mag_vec1 * mag_vec2 > epsilon(1.d0)) then
      temp = dot_product(vec1, vec2) / (mag_vec1 * mag_vec2)
      if (abs(temp) .gt. 1.d0) then
        temp = sign(1.0d0, temp)
      end if
      theta = acos(temp)
    else
      theta = undefined
    end if

  end subroutine angle

  !========================================================================
  !
  !>  @brief       Cross product of two 3D vectors
  !!
  !>  @param[in]   vec1
  !>  @param[in]   vec2
  !!
  !>  @returns     cross vector in 3D
  !!
  !>  @anchor      cross
  !!
  !----------------------------------------------------
  function cross(         &
                   vec1,  & ! <-- DBL() first vector
                   vec2   & ! <-- DBL() second vector
               )

    real(dp), dimension(3)              :: cross
    real(dp), dimension(3), intent(in)  :: vec1
    real(dp), dimension(3), intent(in)  :: vec2

    cross(1) = vec1(2)*vec2(3) - vec1(3)*vec2(2)
    cross(2) = vec1(3)*vec2(1) - vec1(1)*vec2(3)
    cross(3) = vec1(1)*vec2(2) - vec1(2)*vec2(1)

  end function cross

  !!------------------------------------------------------------------------------
  !!
  !> @details  this subroutine solves for the three Roots of a CUBIC equation.  There are
  !!    no restrictions on the coefficients, and imaginary results are passed
  !!    out as separate values.  The general form is y = ax3 + bx2 + cx + d.  Note
  !!    that R1i will ALWAYS be ZERO since there is ALWAYS at least one REAL Root.
  !!
  !> @author        David Vallado     2007, pg 975   719-573-2600    1 Mar 2001
  !> @author        Vitali Braun (20 Feb 2014)
  !!
  !!
  !!
  !!  Locals        :
  !!    temp1       - temporary value
  !!    temp2       - temporary value
  !!    Root1       - temporary value of the Root
  !!    Root2       - temporary value of the Root
  !!    Root3       - temporary value of the Root
  !!    P           - Coefficient of x squared term where x cubed term is 1.0d0
  !!    Q           - Coefficient of x term where x cubed term is 1.0d0
  !!    R           - Coefficient of constant term where x cubed term is 1.0d0
  !!    Delta       - Discriminator for use with Cardans formula
  !!    E0          - ANGLE holder for trigonometric solution
  !!    Phi         - ANGLE used in trigonometric solution
  !!    CosPhi      - Cosine of Phi
  !!    SinPhi      - Sine of Phi
  !!
  !!  Coupling      :
  !!    None.
  !!
  !> @param[in]     a           - Coefficient of x cubed term
  !> @param[in]     b           - Coefficient of x squared term
  !> @param[in]     c           - Coefficient of x term
  !> @param[in]     d           - Constant
  !> @param[out]    R1r         - Real portion of Root 1
  !> @param[out]    R1i         - Imaginary portion of Root 1
  !> @param[out]    R2r         - Real portion of Root 2
  !> @param[out]    R2i         - Imaginary portion of Root 2
  !> @param[out]    R3r         - Real portion of Root 3
  !> @param[out]    R3i         - Imaginary portion of Root 3
  !!
  !> @anchor cubic
  !!
  ! ------------------------------------------------------------------------------
  subroutine cubic( a_in,b_in,c,d, R1r,R1i,R2r,R2i,R3r,R3i )

    implicit none

    real(dp), intent(out) :: R1r,R1i,R2r,R2i,R3r,R3i
    real(dp), intent(in)  :: a_in,b_in,c,d

    real(dp) :: a, b
    real(dp) :: OneThird, temp1, temp2, Root1, Root2, Root3, P, Q, R, Delta, E0, CosPhi, SinPhi, Phi

    ! --------------------  Implementation   ----------------------
    OneThird  = 1.0d0/3.0d0
    R1r   = 0.0d0
    R1i   = 0.0d0
    R2r   = 0.0d0
    R2i   = 0.0d0
    R3r   = 0.0d0
    R3i   = 0.0d0
    Root1 = 0.0d0
    Root2 = 0.0d0
    Root3 = 0.0d0

    ! ----------- Force coefficients into std form ----------------
    a = a_in
    b = b_in

    P = B/A
    Q = C/A
    R = D/A

    a = a_in
    b = b_in

    a = OneThird*( 3.0d0*Q - P*P )
    b = (1.0d0/27.0d0)*( 2.0d0*P*P*P - 9.0d0*P*Q + 27.0d0*R )

    Delta = (a*a*a/27.0d0) + (b*b*0.25d0)

    ! ------------------ Use Cardans formula ----------------------
    if ( Delta > eps9 ) then
      temp1 = (-b*0.5d0)+DSQRT(Delta)
      temp2 = (-b*0.5d0)-DSQRT(Delta)

      if ( abs(temp1) > eps9 ) then
        temp1 = temp1**OneThird
      endif

      if ( abs(temp2) > eps9 ) then
        temp2= temp2**OneThird
      endif

      Root1 = temp1 + temp2
      Root2 = -0.5d0*(temp1 + temp2)
      Root3 = -0.5d0*(temp1 + temp2)
      R2i = -0.5d0*sqrt( 3.0d0 )*(temp1 - temp2)
      R3i = -R2i

    else
      ! --------------- Evaluate zero point ---------------------
      if ( abs( Delta ) < eps9 ) then

        if ( abs(b) < eps9 ) then

          Root1 = -2.0d0 * (b*0.5d0)**OneThird
          Root2 =  (b*0.5d0)**OneThird
          Root3 = Root2

        endif

      else

        ! ------------ Use trigonometric identities -----------
        E0     = 2.0d0*sqrt(-a*OneThird)
        CosPhi = (-b/(2.0d0*sqrt(-a*a*a/27.0d0)) )
        SinPhi = sqrt(1.0d0-CosPhi*CosPhi )
        Phi    = atan2( SinPhi,CosPhi )
        Root1  = E0*cos( Phi*OneThird )
        Root2  = E0*cos( Phi*OneThird + 120.0d0*deg2Rad )
        Root3  = E0*cos( Phi*OneThird + 240.0d0*deg2Rad )

      endif

    endif

    R1r = Root1 - P*OneThird
    R2r = Root2 - P*OneThird
    R3r = Root3 - P*OneThird

  end subroutine cubic

!========================================================================
!!
!> @brief  Compute factorial for given integer
!!
!> @param[in] integer of which the factorial is to be calculated
!!
!> @returns   integer the factorial of input i
!!
!> @anchor factorial
!----------------------------------------------------
  integer function factorial(i)

    integer, intent(in) :: i
    integer             :: j

    factorial = 1
    do j = 2,i
      factorial = factorial*j
    end do

  end function factorial

  !========================================================================
  !!
  !> @brief Initialize matrix to identity
  !!
  !> @param[inout] R the matrix which will be the identity matrix
  !!
  !> @anchor identity_matrix
  !!
  !------------------------------------------------------------------------
  subroutine identity_matrix( R )   ! <--> DBL(:,:) Matrix

    real(dp), dimension(:,:), intent(inout) :: R

    integer :: i

    R = 0.d0
    forall(i=1:size(R,1)) R(i,i) = 1.d0

  end subroutine identity_matrix

!========================================================================
!!
!> @brief Magnitude of a vector
!!
!> @param[in] Vec
!!
!> @returns real(dp) the magnitude of the vector
!!
!> @date

!!
ChK: 13.10.2019 (replaced eps15**2 with epsilon(1.d0))

!!

!!
!> @anchor mag
!!
!----------------------------------------------------
  real(dp) pure function mag(vec)

    real(dp), intent(in) :: vec(3)
    real(dp) temp

    temp = vec(1)*vec(1) + vec(2)*vec(2) + vec(3)*vec(3)

    ! The tolerance is set to 1.d-15, thus the 1.d-30 for the squared test of underflows.
    if (abs(temp) .ge. epsilon(1.d0)) then
      mag = sqrt(temp)
    else
      mag = 0.d0
    end if

  end function mag

  !========================================================================
  !!
  !> @brief Normalize radians to range 0 to 2pi
  !!
  !> @param[in] ang - angle in radians
  !!
  !> @returns real(dp) the angle in radians to range 0 to 2pi
  !!
  !> @anchor angle_2pi
  !-------------------------------------------------------------------------
  real(dp) function angle_2pi ( ang )

    real(dp), intent(in) :: ang
    real(dp) W

    W = mod (ang,twopi)

    if ( W < 0.d0 ) W = W + twopi

    angle_2pi = W

  end function angle_2pi

  !=========================================================================
  !> @brief Reduce an angle to a valid interval
  !!
  !> @param[in] ang  - passed angle to reduce
  !> @param[in] imds - modus identifier
  !> @param[in] jint - interval modus switch
  !> @param[in] ldeg - degree flag
  !!
  !> @returns real(dp) - the reduced angle in the designated intervall
  !!
  !> @anchor redang
  !-------------------------------------------------------------------------
  real(dp) function redang (        & ! reduce an angle to a valid interval
                              ang,  & ! <-- DBL   passed angle to reduce
                              imds, & ! <-- INT   modus identifier
                                      !             1 = interval -pi ... pi
                                      !             2 = interval 0 ... 2*pi
                                      !             3 = interval -pi/2 ... pi/2
                                      !             4 = interval 0 ... pi
                              jint, & ! <-- INT   interval modus switch
                                      !            -1 = open interval   ]x,y]
                                      !             0 = closed interval [x,y]
                                      !             1 = open interval   [x,y[
                              ldeg)   ! <-- LOG   degree flag (.TRUE. = degree)
                                      !                        .FALSE.= radian

    real(dp),  intent(in) :: ang
    integer, intent(in)   :: imds
    integer, intent(in)   :: jint
    logical, intent(in)   :: ldeg
    !--------------------------------------------------------

    !** declaration of local parameters
    integer, parameter ::mmds = 4    ! number of modes supported

    !** declaration of local variables
    real(dp) :: dlw      ! angular difference to lower boundary
    real(dp) :: dup      ! angular difference to upper boundary
    real(dp) :: fac      ! radian/degree factor
    real(dp) :: xlw      ! lower interval boundary (specific)
    real(dp) :: xmds(mmds,2) ! interval boundary (generic)
                             !   1 = lower, 2 = upper
    real(dp) :: xrng     ! interval range (xup-xlw)
    real(dp) :: xup      ! upper interval boundyry (specific)
    integer :: jmds    ! corrected mode switch

    !** define angular borders for different modes
    xmds(1,1) = -pi
    xmds(1,2) = pi
    xmds(2,1) = 0.d0
    xmds(2,2) = twoPi
    xmds(3,1) = -halfPi
    xmds(3,2) = halfPi
    xmds(4,1) = 0.d0
    xmds(4,2) = pi

    !** make sure that mode switch is within valid range
    jmds = min( max(imds,1), mmds)

    !** set angle values according to deg or rad
    if (ldeg) then
       fac = rad2deg
    else
       fac = 1.d0
    end if

    !** set angle offset and range
    xlw  = xmds(jmds,1)*fac
    xup  = xmds(jmds,2)*fac
    xrng = abs(xup-xlw)

    !** reduce angle
    redang = mod( mod(ang+xlw,xrng) + xrng,xrng ) - abs(xlw)

    !** calculate distance of reduced angle from interval boundaries
    dlw = abs(redang - xlw)
    dup = abs(redang - xup)
    !** IF distance to one or more boundary is near zero
    if (dlw<eps15 .OR. dup<eps15) then
       !** resulting angle lies on one border

       !** IF value on lower boundary marked as "open"
       if (jint<0 .AND. dlw<eps15) then
          !** correct lower border result to upper border
          redang = xup
       !** ELSE IF value on upper boundary marked as "open"
       else if (jint>0 .AND. dup<eps15) then
          !** correct upper border result to lower border
          redang = xlw
       !** ELSE
       else if (jint==0) then
          !** take that border which lies next to angle

          if (abs(ang-xup) < abs(ang-xlw)) then
             redang = xup
          else
             redang = xlw
          end if

       end if

    end if

  end function redang

  !========================================================================
  !!
  !>  @brief   Rotation about 1st axis
  !!
  !>  @param[in]  Vec    vector to rotate
  !>  @param[in]  x_val   rotation angle in rad
  !>  @param[out] out_vec result vector
  !!
  !>  @anchor  rot1
  !----------------------------------------------------
  subroutine rot1(        &
                  vec,    &! <-- DBL() vector to rotate
                  x_val,  &! <-- DBL   rotation angle (rad)
                  out_vec &! --> DBL() result vector
                 )

    !** interface
    !-----------------------------------------------
    real(dp), dimension(3), intent(in) :: vec
    real(dp),               intent(in) :: x_val
    real(dp), dimension(3), intent(out) :: out_vec
    !-----------------------------------------------

    ! -----------------------------  Locals  ------------------------------
    real(dp) c, s

    c    = cos( x_val )
    s    = sin( x_val )

    out_vec(3)= c*vec(3) - s*vec(2)
    out_vec(2)= c*vec(2) + s*vec(3)
    out_vec(1)= vec(1)

    return

  end subroutine rot1

  !========================================================================
  !
  !>  @brief Rotation about 2nd axis
  !>  @anchor  rot2
  !>  @param[in]  Vec    vector to rotate
  !>  @param[in]  x_val   rotation angle in rad
  !>  @param[out] out_vec result vector
  !----------------------------------------------------
  subroutine rot2(         &
                   vec,    & ! <-- DBL() vector to rotate
                   x_val,  & ! <-- DBL   rotation angle (rad)
                   out_vec & ! --> DBL() result vector
                 )

    !** interface
    !-----------------------------------------------
    real(dp), dimension(3), intent(in) :: vec
    real(dp),               intent(in) :: x_val

    real(dp), dimension(3), intent(out) :: out_vec
    !-----------------------------------------------

    ! -----------------------------  Locals  ------------------------------
    real(dp) c, s

    c    = cos( x_val )
    s    = sin( x_val )

    out_vec(3) = c*vec(3) + s*vec(1)
    out_vec(1) = c*vec(1) - s*vec(3)
    out_vec(2) = vec(2)

    return

  end subroutine rot2

  !========================================================================
  !!
  !>  @brief   Rotation about 3rd axis
  !!
  !>  @param[in]  vec     vector to rotate
  !>  @param[in]  x_val   rotation angle in rad
  !>  @param[out] out_vec result vector
  !!
  !>  @anchor  rot3
  !----------------------------------------------------
  subroutine rot3(         &
                   vec,    & ! <-- DBL() vector to rotate
                   x_val,  & ! <-- DBL   rotation angle (rad)
                   out_vec & ! --> DBL() result vector
                 )

    !** interface
    !-----------------------------------------------
    real(dp), dimension(3), intent(in) :: vec
    real(dp),               intent(in) :: x_val

    real(dp), dimension(3), intent(out) :: out_vec
    !-----------------------------------------------

    ! -----------------------------  Locals  ------------------------------
    real(dp) c, s

    c    = cos(x_val)
    s    = sin(x_val)

    out_vec(2) = c*vec(2) - s*vec(1)
    out_vec(1) = c*vec(1) + s*vec(2)
    out_vec(3) = vec(3)

    return

  end subroutine rot3

  !========================================================================
  !!
  !>  @brief Rotate matrix wrt. x axis
  !!
  !>  @param[in]  angle  rotation angle in rad
  !>  @param[inout] matrix the (3,3) matrix to rotate
  !!
  !>  @anchor  rot1_matrix
  !----------------------------------------------------
  subroutine rot1_matrix(         &
                          angle,  & ! <--  DBL      angle in radians
                          matrix  & ! <--> DBL(3,3) matrix
                        )
  !-----------------------------------------------------

    !** interface
    !----------------------------------------------
    real(dp), intent(in) :: angle
    real(dp), dimension(3,3), intent(inout) :: matrix
    !----------------------------------------------

    real(dp) :: S, C, A21, A22, A23, A31, A32, A33

    S = sin(angle)
    C = cos(angle)

    A21 =   C*matrix(2,1) + S*matrix(3,1)
    A22 =   C*matrix(2,2) + S*matrix(3,2)
    A23 =   C*matrix(2,3) + S*matrix(3,3)
    A31 = - S*matrix(2,1) + C*matrix(3,1)
    A32 = - S*matrix(2,2) + C*matrix(3,2)
    A33 = - S*matrix(2,3) + C*matrix(3,3)

    matrix(2,1) = A21
    matrix(2,2) = A22
    matrix(2,3) = A23
    matrix(3,1) = A31
    matrix(3,2) = A32
    matrix(3,3) = A33

  end subroutine rot1_matrix

  !========================================================================
  !!
  !>  @brief Rotate matrix wrt. y axis
  !!
  !>  @param[in]  angle  rotation angle in rad
  !>  @param[inout] matrix the (3,3) matrix to rotate
  !!
  !>  @anchor  rot2_matrix
  !----------------------------------------------------
  subroutine rot2_matrix (         &
                           angle,  &  ! <-- DBL      angle in radians
                           matrix  &  ! --> DBL(3,3) matrix
                         )
  !-----------------------------------------------------

    !** interface
    !----------------------------------------------
    real(dp), intent(in) :: angle
    real(dp), dimension(3,3), intent(inout) :: matrix
    !----------------------------------------------

    real(dp) :: S, C, A11, A12, A13, A31, A32, A33

    S = sin(angle)
    C = cos(angle)

    A11 = C*matrix(1,1) - S*matrix(3,1)
    A12 = C*matrix(1,2) - S*matrix(3,2)
    A13 = C*matrix(1,3) - S*matrix(3,3)
    A31 = S*matrix(1,1) + C*matrix(3,1)
    A32 = S*matrix(1,2) + C*matrix(3,2)
    A33 = S*matrix(1,3) + C*matrix(3,3)

    matrix(1,1) = A11
    matrix(1,2) = A12
    matrix(1,3) = A13
    matrix(3,1) = A31
    matrix(3,2) = A32
    matrix(3,3) = A33

  end subroutine rot2_matrix
  !------------------------------------------------------

  !========================================================================
  !
  !>  @brief Rotate matrix wrt. z axis
  !!
  !>  @param[in]  angle  rotation angle in rad
  !>  @param[inout] matrix the (3,3) matrix to rotate
  !!
  !>  @anchor  rot3_matrix
  !----------------------------------------------------
  subroutine rot3_matrix (        &
                           angle, & ! <-- DBL      angle in radians
                           matrix & ! --> DBL(3,3) matrix
                         )

    !** interface
    !----------------------------------------------
    real(dp), intent(in)                    :: angle
    real(dp), dimension(3,3), intent(inout) :: matrix
    !----------------------------------------------

    real(dp) :: S, C, A11, A12, A13, A21, A22, A23

    S = sin(angle)
    C = cos(angle)

    A11 =   C*matrix(1,1) + S*matrix(2,1)
    A12 =   C*matrix(1,2) + S*matrix(2,2)
    A13 =   C*matrix(1,3) + S*matrix(2,3)
    A21 = - S*matrix(1,1) + C*matrix(2,1)
    A22 = - S*matrix(1,2) + C*matrix(2,2)
    A23 = - S*matrix(1,3) + C*matrix(2,3)

    matrix(1,1) = A11
    matrix(1,2) = A12
    matrix(1,3) = A13
    matrix(2,1) = A21
    matrix(2,2) = A22
    matrix(2,3) = A23

  end subroutine rot3_matrix

  !========================================================================
  !
  !>  @brief    Get extreme values for a given discrete signal (array)
  !!
  !>  @author   Vitali Braun
  !!
  !>  @date

  !!
21.04.2015 (initial design)

  !!

  !!
  !!  @anchor   get_extrema
  !----------------------------------------------------
  subroutine get_extrema(x, y, typ, extr, nextr)

    real(dp), dimension(:), intent(in) :: x
    real(dp), dimension(:), intent(in) :: y
    character(len=3),       intent(in) :: typ
    real(dp), dimension(size(y),3), intent(out) :: extr
    integer, intent(out) :: nextr

    character(len=*), parameter :: csubid = 'get_extrema'

    integer :: i
    integer :: lasti

    if(isControlled()) then
      if(hasToReturn()) return
      call checkIn(csubid)
    end if

    nextr = 0
    lasti = 0

    if(typ == 'MAX') then ! search maxima

      do i = 3, size(y)-2
        if((y(i) - y(i-1)) > 0.d0 .and. (y(i+1) - y(i)) < 0.d0) then      ! finite difference of first order
          nextr = nextr + 1
          extr(nextr,1) = x(i)
          extr(nextr,2) = y(i)
          extr(nextr,3) = 1.d0    ! max
        else if(i > lasti+2 .and. (y(i)-2.d0*y(i-1)+y(i-2)) < 0.d0 .and. (y(i+2)-2.d0*y(i+1)+y(i)) > 0.d0) then  ! ... second order
          lasti = i
          nextr = nextr + 1
          extr(nextr,1) = x(i)
          extr(nextr,2) = y(i)
          extr(nextr,3) = 0.d0    ! turning point
        end if
      end do

    else if(typ == 'MIN') then

      do i = 3, size(y)-2
        if((y(i) - y(i-1)) < 0.d0 .and. (y(i+1) - y(i)) > 0.d0) then ! finite difference of first order
          nextr = nextr + 1
          extr(nextr,1) = x(i)
          extr(nextr,2) = y(i)
          extr(nextr,3) = -1.d0    ! min
        else if(i > lasti+2 .and. (y(i)-2.d0*y(i-1)+y(i-2)) > 0.d0 .and. (y(i+2)-2.d0*y(i+1)+y(i)) < 0.d0) then  ! ... second order
          lasti = i
          nextr = nextr + 1
          extr(nextr,1) = x(i)
          extr(nextr,2) = y(i)
          extr(nextr,3) = 0.d0    ! turning point
        end if
      end do

    else
      call setError(E_UNKNOWN_PARAMETER, FATAL)
      return
    end if

    if(isControlled()) then
      call checkout(csubid)
    end if

  end subroutine get_extrema

  !========================================================================
  !
  !>  @brief    Outer product of two vectors a and b
  !!
  !>  @author   Vitali Braun
  !!
  !>  @date

  !!
26.07.2013 (initial design)

  !!

  !!
  !>  @param[in] a
  !>  @param[in] b
  !!
  !>  @returns the outer product of a and b
  !!
  !!  @anchor   outerproduct
  !----------------------------------------------------
  function outerproduct(a,b)

    real(dp), dimension(:), intent(in) :: a
    real(dp), dimension(:), intent(in) :: b
    real(dp), dimension(size(a), size(b)) :: outerproduct

    outerproduct = spread(a,dim=2,ncopies=size(b)) * spread(b,dim=1,ncopies=size(a))

  end function outerproduct

end module slam_math


program ch1206
    ! Easter
    implicit none

    integer ::  year, metcyc, century, error1, &
        error2, day
    integer :: epact, luna, temp

    print *, ' input the year for which easter'
    print *, ' is to be calculated'
    print *, ' enter the whole year, e.g. 1978 '
    read *, year

    metcyc = mod(year,19)+1
    if (year<=1582) then
        day = (5*year)/4
        epact = mod(11*metcyc-4,30)+1
    else
        century = (year/100)+1
        error1 = (3*century/4)-12
        error2 = ((8*century+5)/25)-5
        day = (5*year/4)-error1-10
        temp = 11*metcyc+20+error2-error1
        epact = mod(temp,30)
        if (epact<=0) then
            epact = 30+epact
        end if
        if ((epact==25 .and. metcyc>11) .or. &
            epact==24) then
            epact = epact+1
        end if
    end if
    luna = 44-epact
    if (luna<21) then
        luna = luna+30
    end if
    luna = luna+7-(mod(day+luna,7))
    if (luna>31) then
        luna = luna-31
        print *, ' for the year ', year
        print *, ' easter falls on April ', luna
    else
        print *, ' for the year ', year
        print *, ' easter falls on march ', luna
    end if
end program


!==============================================================================!
  program Stretch
!------------------------------------------------------------------------------!
!   Places the nodes on the line defined with local block position             !
!------------------------------------------------------------------------------!
  implicit none
!-----------------------------------[Locals]-----------------------------------!
  integer           :: n, i, case
  real              :: x0, delx, t, dt, ddt, pr, xi
  real              :: x(0:1000)
  real              :: w
  character(len=20) :: file1
!======================================================================!

  x0=0.0

  write(*,*) 'Distance: '
  read(*,*)  delx
  write(*,*) 'Weigth: '
  read(*,*)  w
  write(*,*) 'Number of cells: '
  read(*,*)  n

  x(0) = x0

  !-------------------------!
  !   Linear distribution   !
  !-------------------------!
  if(w  > 0.0) then
    ddt = ( 2.0*(1.0-w) ) / ( 1.0*n*(1.0*n-1.0)*(1.0+w) )
    t=0.0
    do i=1,n
      dt=1.0/(1.0*n)+(1.0*i-0.5*(1.0*n+1)) * ddt
      t=t+dt
      x(i) = x0 + t*delx
    end do

  !-----------------------------!
  !   Hyperbolic distribution   !
  !-----------------------------!
  else
    case = 0
    if     ((w  >  -0.5).and.(w <=  -0.25)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 1
    else if((w >=  -0.75).and.(w  <  -0.5)) then
      pr = 1.0 - abs(0.5 - abs(w))
      case = 2
    else
      pr = -w
      case = 3
    endif

    do i=1,n
      if(case == 1) xi = -1.0*(1.0*i)/(1.0*n)
      if(case == 2) xi =  1.0 - 1.0*(1.0*i)/(1.0*n)
      if(case == 3) xi = -1.0 + 2.0*(1.0*i)/(1.0*n)
      if    (case == 1) then
        x(i) = x0 - (tanh(xi*atanh(pr))/pr)*delx
      elseif(case == 2) then
        x(i) = x0 + delx - (tanh(xi*atanh(pr))/pr)*delx
      elseif(case == 3) then
        x(i) = x0 + 0.5*(1.0+tanh(xi*atanh(pr))/pr)*delx
      endif
    end do

  endif

  !--------------------------------!
  !   Print out the distribution   !
  !--------------------------------!
  write(*,*) ' number:   node:                  cell:'
  do i=n,1,-1
    write(*,'(I6,F12.6,A10)') i+1, x(i),              ' +-------+'
    write(*,'(I6,A23,F12.6)') i,  '|   o   | ', 0.5*(x(i)+x(i-1))
  end do
  write(*,'(I6,F12.6,A10)') i+1, x(0),              ' +-------+'
  write(*,*) 'wall:    //////////////////////////////'

  file1 = 'fileout'

  open(3,file=file1)

  do i = 1, n

   write(3,*) 0.5*(x(i)+x(i-1))

  end do

  close (3)

  end program


!Reference: 田口俊弘 著 Fortran ハンドブック技術評論社１４４ｐ
program dka
    implicit none
    real pa(0:10),eps
    complex zroot(10),zz
    integer i,n,ind,j
    pa(0) = 580
    pa(1) = 1398
    pa(2) = 232
    pa(3) = 593
    pa(4) = -708
    pa(5) = 180
    n = 5
    eps = 1e-7
    call dkaroot(pa,n,zroot,eps,ind)
    do i=1,n
        zz=0
        do j=n,0,-1
            zz=zz*zroot(i)+pa(j)
        enddo
        print *,i,zroot(i),abs(zz),ind
    enddo
end program dka

subroutine dkaroot(pa,n,zroot,eps,ind)
    implicit none
    real pa(0:n),p1(0:n-1),p2(0:n),eps,beta,rad,ang,del
    complex zroot(*),z(n),dz,zp,zd
    integer n,ind,i,j,it
    integer,parameter :: itmax=1000000
    real,parameter :: pi2=6.28319

    if(pa(n)==0) then
        ind = -1
        return
    endif
    !convert p1 into monic
    p2(n) = 1
    do i=0,n-1
        p1(i)=pa(i)/pa(n)
        p2(i)=p1(i)
    enddo

    beta = p1(n-1)/n
    do i=0,n-2
        do j = n-1, i, -1
            p2(j) = p2(j+1)*beta + p2(j)
        enddo
        p2(i) = -abs(p2(i))
    enddo
    p2(n-1)=0

    call proot1_newton(p2,n,rad)
    do i=1,n
        ang=(pi2*(i-1)+1.5)/n
        z(i)=-beta+rad*cmplx(cos(ang),sin(ang))
    enddo

    do it = 1, itmax
        del = 0
        do i=1,n
            zp=1
            zd=1
            do j = n-1,0,-1
                zp=zp*z(i)+p1(j)
                if (j+1/= i ) zd=zd*(z(i)-z(j+1))
            enddo
            if (zd==0) then
                ind = -2
                return
            endif
            dz=-zp/zd
            del = max(del,abs(dz))
            z(i)=z(i)+dz
        enddo
        if(del<eps) exit
    enddo
    if(it>itmax)then
        ind = -itmax
    else
        ind = it
    endif
    do i=1,n
        zroot(i)=z(i)
    enddo
end subroutine dkaroot

subroutine proot1_newton(p1,n,x)
    implicit none
    real p1(0:n-1),x,eps,pp,dp,x0,x1
    integer n,it,j,m0
    integer, parameter :: Itmax =100
    eps = 1e-7
    x0=0
    m0=0
    do j = 0,n-1
        if(p1(j)/= 0) m0=m0+1
    enddo
    do j=0,n-1
        if(p1(j)/= 0) then
            x0=max(x0,abs(m0*p1(j))**(1.0/(n-j)))
        endif
    enddo

    do it=1,itmax
        pp=1
        dp=0
        do j = n-1,0,-1
            dp=dp*x0+pp
            pp=pp*x0+p1(j)
        enddo
        if(pp==0)exit
        x1=x0 - pp/dp
        if(abs(x1-x0)<eps) exit
        x0=x1
    enddo
    x=x1
end subroutine proot1_newton


*DECK RD
      REAL FUNCTION RD (X, Y, Z, IER)
C***BEGIN PROLOGUE  RD
C***PURPOSE  Compute the incomplete or complete elliptic integral of the
C            2nd kind.  For X and Y nonnegative, X+Y and Z positive,
C             RD(X,Y,Z) = Integral from zero to infinity of
C                                -1/2     -1/2     -3/2
C                      (3/2)(t+X)    (t+Y)    (t+Z)    dt.
C            If X or Y is zero, the integral is complete.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      SINGLE PRECISION (RD-S, DRD-D)
C***KEYWORDS  COMPLETE ELLIPTIC INTEGRAL, DUPLICATION THEOREM,
C             INCOMPLETE ELLIPTIC INTEGRAL, INTEGRAL OF THE SECOND KIND,
C             TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     RD
C          Evaluate an INCOMPLETE (or COMPLETE) ELLIPTIC INTEGRAL
C          of the second kind
C          Standard FORTRAN function routine
C          Single precision version
C          The routine calculates an approximation result to
C          RD(X,Y,Z) = Integral from zero to infinity of
C                              -1/2     -1/2     -3/2
C                    (3/2)(t+X)    (t+Y)    (t+Z)    dt,
C          where X and Y are nonnegative, X + Y is positive, and Z is
C          positive.  If X or Y is zero, the integral is COMPLETE.
C          The duplication theorem is iterated until the variables are
C          nearly equal, and the function is then expanded in Taylor
C          series to fifth order.
C
C   2.     Calling Sequence
C
C          RD( X, Y, Z, IER )
C
C          Parameters on Entry
C          Values assigned by the calling routine
C
C          X      - Single precision, nonnegative variable
C
C          Y      - Single precision, nonnegative variable
C
C                   X + Y is positive
C
C          Z      - Real, positive variable
C
C
C
C          On Return     (values assigned by the RD routine)
C
C          RD     - Real approximation to the integral
C
C
C          IER    - Integer
C
C                   IER = 0 Normal and reliable termination of the
C                           routine.  It is assumed that the requested
C                           accuracy has been achieved.
C
C                   IER >  0 Abnormal termination of the routine
C
C
C          X, Y, Z are unaltered.
C
C   3.    Error Messages
C
C         Value of IER assigned by the RD routine
C
C                  Value Assigned         Error Message Printed
C                  IER = 1                MIN(X,Y) .LT. 0.0E0
C                      = 2                MIN(X + Y, Z ) .LT. LOLIM
C                      = 3                MAX(X,Y,Z) .GT. UPLIM
C
C
C   4.     Control Parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X, Y, and Z
C
C          LOLIM  - Lower limit of valid arguments
C
C                    Not less  than 2 / (machine maximum) ** (2/3).
C
C          UPLIM  - Upper limit of valid arguments
C
C                    Not greater than (0.1E0 * ERRTOL / machine
C                    minimum) ** (2/3), where ERRTOL is described below.
C                    In the following table it is assumed that ERRTOL
C                    will never be chosen smaller than 1.0E-5.
C
C
C                    Acceptable Values For:   LOLIM      UPLIM
C                    IBM 360/370 SERIES   :   6.0E-51     1.0E+48
C                    CDC 6000/7000 SERIES :   5.0E-215    2.0E+191
C                    UNIVAC 1100 SERIES   :   1.0E-25     2.0E+21
C                    CRAY                 :   3.0E-1644   1.69E+1640
C                    VAX 11 SERIES        :   1.0E-25     4.5E+21
C
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C          ERRTOL    Relative error due to truncation is less than
C                    3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2.
C
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C
C          Sample Choices:  ERRTOL   Relative Truncation
C                                    error less than
C                           1.0E-3    4.0E-18
C                           3.0E-3    3.0E-15
C                           1.0E-2    4.0E-12
C                           3.0E-2    3.0E-9
C                           1.0E-1    4.0E-6
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   RD Special Comments
C
C
C
C          Check: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y)
C          = 3 /  SQRT(X * Y * Z), where X, Y, and Z are positive.
C
C
C          On Input:
C
C          X, Y, and Z are the variables in the integral RD(X,Y,Z).
C
C
C          On Output:
C
C
C          X, Y, and Z are unaltered.
C
C
C
C          ********************************************************
C
C           WARNING: Changes in the program may improve speed at the
C                    expense of robustness.
C
C
C
C    -------------------------------------------------------------------
C
C
C   Special Functions via RD and RF
C
C
C                  Legendre form of ELLIPTIC INTEGRAL of 2nd kind
C                  ----------------------------------------------
C
C
C                                            2         2   2
C                  E(PHI,K) = SIN(PHI) RF(COS (PHI),1-K SIN (PHI),1) -
C
C                     2      3            2         2   2
C                  -(K/3) SIN (PHI) RD(COS (PHI),1-K SIN (PHI),1)
C
C
C                                 2        2           2
C                  E(K) = RF(0,1-K ,1) - (K/3) RD(0,1-K ,1)
C
C
C                         PI/2     2   2      1/2
C                       = INT  (1-K SIN (PHI) )  D PHI
C                          0
C
C
C
C                  Bulirsch form of ELLIPTIC INTEGRAL of 2nd kind
C                  ----------------------------------------------
C
C                                              2 2    2
C                  EL2(X,KC,A,B) = AX RF(1,1+KC X ,1+X ) +
C
C                                              3         2 2    2
C                                 +(1/3)(B-A) X RD(1,1+KC X ,1+X )
C
C
C
C                  Legendre form of alternative ELLIPTIC INTEGRAL of 2nd
C                  -----------------------------------------------------
C                        kind
C                        ----
C
C                            Q     2       2   2  -1/2
C                  D(Q,K) = INT SIN P  (1-K SIN P)     DP
C                            0
C
C
C
C                                   3          2     2   2
C                  D(Q,K) =(1/3)(SIN Q)  RD(COS Q,1-K SIN Q,1)
C
C
C
C
C
C                  Lemniscate constant B
C                  ---------------------
C
C
C
C                       1    2    4 -1/2
C                  B = INT  S (1-S )    DS
C                       0
C
C
C                  B =(1/3)RD (0,2,1)
C
C
C
C
C                  Heuman's LAMBDA function
C                  ------------------------
C
C
C
C                  (PI/2) LAMBDA0(A,B) =
C
C                                       2                2
C                     = SIN(B) (RF(0,COS (A),1)-(1/3) SIN (A) *
C
C                               2              2         2       2
C                      *RD(0,COS (A),1)) RF(COS (B),1-COS (A) SIN (B),1)
C
C                               2       3            2
C                     -(1/3) COS (A) SIN (B) RF(0,COS (A),1) *
C
C                             2         2       2
C                      *RD(COS (B),1-COS (A) SIN (B),1)
C
C
C
C                  Jacobi ZETA function
C                  --------------------
C
C
C                             2                2       2   2
C                  Z(B,K) = (K/3) SIN(B) RF(COS (B),1-K SIN (B),1)
C
C
C                                      2            2
C                             *RD(0,1-K ,1)/RF(0,1-K ,1)
C
C                               2       3          2       2   2
C                            -(K /3) SIN (B) RD(COS (B),1-K SIN (B),1)
C
C
C    -------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Modify calls to XERMSG to put in standard form.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RD
      CHARACTER*16 XERN3, XERN4, XERN5, XERN6
      INTEGER IER
      REAL LOLIM, UPLIM, EPSLON, ERRTOL
      REAL C1, C2, C3, C4, EA, EB, EC, ED, EF, LAMDA
      REAL MU, POWER4, SIGMA, S1, S2, X, XN, XNDEV
      REAL XNROOT, Y, YN, YNDEV, YNROOT, Z, ZN, ZNDEV, ZNROOT
      LOGICAL FIRST
      SAVE ERRTOL, LOLIM, UPLIM, C1, C2, C3, C4, FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  RD
      IF (FIRST) THEN
         ERRTOL = (R1MACH(3)/3.0E0)**(1.0E0/6.0E0)
         LOLIM  = 2.0E0/(R1MACH(2))**(2.0E0/3.0E0)
         TUPLIM = R1MACH(1)**(1.0E0/3.0E0)
         TUPLIM = (0.10E0*ERRTOL)**(1.0E0/3.0E0)/TUPLIM
         UPLIM  = TUPLIM**2.0E0
C
         C1 = 3.0E0/14.0E0
         C2 = 1.0E0/6.0E0
         C3 = 9.0E0/22.0E0
         C4 = 3.0E0/26.0E0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      RD = 0.0E0
      IF( MIN(X,Y).LT.0.0E0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'RD',
     *      'MIN(X,Y).LT.0 WHERE X = ' // XERN3 // ' AND Y = ' //
     *      XERN4, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y,Z).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'RD',
     *      'MAX(X,Y,Z).GT.UPLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND UPLIM = ' // XERN6,
     *      3, 1)
         RETURN
      ENDIF
C
      IF (MIN(X+Y,Z).LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') Z
         WRITE (XERN6, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'RD',
     *      'MIN(X+Y,Z).LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' //
     *      XERN4 // ' Z = ' // XERN5 // ' AND LOLIM = ' // XERN6,
     *      2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
      ZN = Z
      SIGMA = 0.0E0
      POWER4 = 1.0E0
C
   30 MU = (XN+YN+3.0E0*ZN)*0.20E0
      XNDEV = (MU-XN)/MU
      YNDEV = (MU-YN)/MU
      ZNDEV = (MU-ZN)/MU
      EPSLON = MAX(ABS(XNDEV), ABS(YNDEV), ABS(ZNDEV))
      IF (EPSLON.LT.ERRTOL) GO TO 40
      XNROOT = SQRT(XN)
      YNROOT = SQRT(YN)
      ZNROOT = SQRT(ZN)
      LAMDA = XNROOT*(YNROOT+ZNROOT) + YNROOT*ZNROOT
      SIGMA = SIGMA + POWER4/(ZNROOT*(ZN+LAMDA))
      POWER4 = POWER4*0.250E0
      XN = (XN+LAMDA)*0.250E0
      YN = (YN+LAMDA)*0.250E0
      ZN = (ZN+LAMDA)*0.250E0
      GO TO 30
C
   40 EA = XNDEV*YNDEV
      EB = ZNDEV*ZNDEV
      EC = EA - EB
      ED = EA - 6.0E0*EB
      EF = ED + EC + EC
      S1 = ED*(-C1+0.250E0*C3*ED-1.50E0*C4*ZNDEV*EF)
      S2 = ZNDEV*(C2*EF+ZNDEV*(-C3*EC+ZNDEV*C4*EA))
      RD = 3.0E0*SIGMA + POWER4*(1.0E0+S1+S2)/(MU* SQRT(MU))
C
      RETURN
      END


module local_routines
    !
    ! Setup for the parabolic canal problem
    !
    use global_mod, only: dp, ip, wall_elevation, gravity
    use domain_mod, only: domain_type, STG, UH, VH, ELV
    use logging_mod, only: log_output_unit
    implicit none

    real(dp), parameter :: problem_a = 3000.0_dp
    real(dp), parameter :: problem_h0 = 10.0_dp
    real(dp), parameter :: problem_g = 10.0_dp

    real(dp) :: problem_ohm ! parameter that appears in the solution

    contains

    subroutine set_initial_conditions(domain)
        !
        ! Initial conditions
        !
        class(domain_type), target, intent(inout):: domain

        integer(ip):: i,j
        real(dp):: x, y, cx, cy, initial_stage_1, initial_stage_2, radius
        real(dp) :: imid, jmid, coriolis_f

        !We assume coriolis is constant over these small spatial scales
        write(log_output_unit,*) 'Coriolis range: ', minval(domain%coriolis), maxval(domain%coriolis)
        coriolis_f = domain%coriolis(domain%nx(2)/2)
        write(log_output_unit,*) 'Forcing coriolis = ', coriolis_f
        domain%coriolis = coriolis_f

        ! This parameter appears in the solution repeatedly.
        problem_ohm = sqrt(coriolis_f**2 + 2 * gravity * problem_h0/problem_a**2)

        ! Define parabolic elevation
        imid = domain%nx(1)/2.0_dp
        do j = 1, domain%nx(2)
            do i = 1, domain%nx(1)
                ! A 'cartesian' x coordinate
                x = (i-imid)*domain%distance_bottom_edge(j)
                ! Elevation
                domain%U(i,j,ELV) = - problem_h0 * (1.0_dp - (x/problem_a)**2)
            end do
        end do

        !@! Walls to the north and south and east and west
        !domain%U(:,1:2, ELV) = 100.0_dp
        !domain%U(:, (domain%nx(2)-1):domain%nx(2), ELV) = 100.0_dp
        !domain%U(1:2,:, ELV) = 100.0_dp
        !domain%U((domain%nx(1)-1):domain%nx(1),:, ELV) = 100.0_dp

        ! Compute the initial stage, specify the initial VH (nonzero)
        ! and the initial UH (zero).
        do j = 1, domain%nx(2)
            do i = 1, domain%nx(1)
                ! A 'cartesian' x coordinate
                x = (i-imid)*domain%distance_bottom_edge(j)
                ! Stage
                domain%U(i,j,STG) = -problem_g**2 * problem_h0 / problem_a**2 + &
                    2 * problem_G * problem_h0 / problem_a**2 * x
                ! Ensure stage >= elevation
                domain%U(i,j,STG) = max(domain%U(i,j,STG), domain%U(i,j,ELV))

                ! VH
                domain%U(i,j,VH) = - problem_G * coriolis_f * (domain%U(i,j,STG) - domain%U(i,j,ELV))

                ! UH begins as zero
                domain%U(i,j,UH) = 0.0_dp

            end do
        end do

        domain%manning_squared = 0.0_dp

    end subroutine

end module

!@!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program parabolic_canal
    !!
    !! Flow in a parabolic canal with coriolis. This problem has an analytical solution
    !! by Thacker, which is reviewed in Sampson et al. (2006) Moving boundary shallow water flow above
    !! parabolic bottom topography, ANZIAM J. 47 (EMAC2005) pp.C373–C387
    !!
    use global_mod, only: ip, dp, charlen, default_nonlinear_timestepping_method
    use multidomain_mod, only: multidomain_type
    use file_io_mod, only: read_csv_into_array
    use local_routines
    use boundary_mod, only: transmissive_boundary
    implicit none

    integer(ip):: i, nsteps
    real(dp):: last_write_time
    type(multidomain_type):: md

    ! Approx timestep between outputs
    real(dp), parameter :: approximate_writeout_frequency = 30.0_dp
    real(dp), parameter :: final_time = 7200.0_dp * 1

    real(dp), parameter :: mesh_refine = 3.0_dp

    real(dp), parameter, dimension(2):: global_ll = [0.0_dp, 30.0_dp] ! Latitude so we have Coriolis
        ! lower-left corner coordinate

    ! A 'wide' setup in the NS direction. This performs poorly for the VH component -- perhaps because of
    ! the gradients in grid-size in the NS direction (due to lon/lat coordinates) introduces genuinely
    ! non-NS-periodic effects (and the VH flow is very slight compared to the UH flow, so easily corrupted
    ! by any numerical issues)
    !real(dp), parameter, dimension(2):: global_lw = [0.10372884337_dp, 0.0044915764_dp*20]
    !    ! length/width (10 km x 10km @ 30 degrees latitude)
    !integer(ip), parameter, dimension(2):: global_nx = nint([200, 200]*mesh_refine) !
    !    ! grid size (number of x/y cells)

    ! A 'narrow' setup in the NS direction.
    real(dp), parameter, dimension(2):: global_lw = [0.10372884337_dp, 0.0044915764_dp]
        ! length/width (10 km x 500 m @ 30 degrees latitude)
    integer(ip), parameter, dimension(2):: global_nx = nint([200, 5]*mesh_refine) !
        ! grid size (number of x/y cells)

    real(dp) :: non_adaptive_ts
        ! Fixed timestep
    character(len=charlen) :: timestepping_method

#ifndef SPHERICAL
    stop 'Program assumes spherical coordinates - you must compile with -DSPHERICAL'
#endif

    call get_command_argument(1, timestepping_method)

    ! Only one domain
    allocate(md%domains(1))

    md%domains(1)%timestepping_method = timestepping_method !default_nonlinear_timestepping_method
    md%domains(1)%lw = global_lw
    md%domains(1)%nx = global_nx
    md%domains(1)%lower_left = global_ll

    ! Make the domain NS periodic
    md%periodic_ys = [global_ll(2), global_ll(2) + global_lw(2)]

    ! Setup
    call md%setup()

    ! Set initial conditions
    CALL set_initial_conditions(md%domains(1))

    ! Choose the fixed timestep
    if(md%domains(1)%timestepping_method == 'cliffs') then
        ! Currently cliffs does not perform well on this problem for the VH component.
        ! While there are some wet-dry artefacts, possibly it is also more sensitive to the
        ! NS-periodic approximation than the other solvers?
        non_adaptive_ts = md%domains(1)%stationary_timestep_max() * 0.7_dp
        md%domains(1)%cliffs_minimum_allowed_depth = 0.03_dp
    else
        non_adaptive_ts = md%domains(1)%stationary_timestep_max() * 0.9_dp
    end if

    call md%make_initial_conditions_consistent()

    ! Evolve the code
    do while (.TRUE.)

        call md%write_outputs_and_print_statistics(&
            approximate_writeout_frequency = approximate_writeout_frequency)

        if(md%domains(1)%time > final_time) then
            exit
        end if

        call md%evolve_one_step(non_adaptive_ts)

    end do

    call md%finalise_and_print_timers

end program


      implicit double precision (a-h,o-z)
      external userf

      write(6,*) 'initial value'
      read(5,*) x0
      write(6,*) 'critelia epsilon'
      read(5,*) e
      write(6,*) 'max iteration'
      read(5,*) nmax
c     Newton-Raphson method
      call s_newt(n,x0,e,nmax,userf)
      write(6,10) 'num iteration N:=',n,'solution x(n)=',x0
   10 format(1h,a11,i4,1h,a8,f10.7)
      stop
      end

      subroutine s_newt(n,x0,e,nmax,func)
      implicit double precision (a-h,o-z)
      n=0
      xn=x0
  100 if(n.lt.nmax) then
        call func(fun,dfun,xn)
        x0=xn-fun/dfun
        n=n+1
        if(abs(xn-x0).gt.e) then
          xn=x0
          go to 100
        end if
      end if
      return
      end

      subroutine userf(fun,dfun,x)
      implicit double precision (a-h,o-z)
      x2 = x*x
      fun=x2*x-1.0
      dfun = 3.0*x2
      return
      end


! RUN: %S/test_folding.sh %s %t %flang_fc1
module m
  complex, parameter :: z1 = 1. + (2., 3.)
  logical, parameter :: test_z1 = z1 == (3., 3.)
  complex, parameter :: z2 = 1 + (2., 3.)
  logical, parameter :: test_z2 = z2 == (3., 3.)
  complex, parameter :: z3 = 2. * (3., 4.)
  logical, parameter :: test_z3 = z3 == (6., 8.)
  complex, parameter :: z4 = 2 * (3., 4.)
  logical, parameter :: test_z4 = z4 == (6., 8.)
  complex, parameter :: z5 = 5. - (3., 4.)
  logical, parameter :: test_z5 = z5 == (2., -4.)
  complex, parameter :: z6 = 5 - (3., 4.)
  logical, parameter :: test_z6 = z6 == (2., -4.)
  complex, parameter :: z11 = (2., 3.) + 1.
  logical, parameter :: test_z11 = z11 == (3., 3.)
  complex, parameter :: z12 = (2., 3.) + 1
  logical, parameter :: test_z12 = z12 == (3., 3.)
  complex, parameter :: z13 = (3., 4.) * 2.
  logical, parameter :: test_z13 = z13 == (6., 8.)
  complex, parameter :: z14 = (3., 4.) * 2
  logical, parameter :: test_z14 = z14 == (6., 8.)
  complex, parameter :: z15 = (3., 4.) - 1.
  logical, parameter :: test_z15 = z15 == (2., 4.)
  complex, parameter :: z16 = (3., 4.) - 1
  logical, parameter :: test_z16 = z16 == (2., 4.)
  complex, parameter :: z17 = (3., 4.) / 2.
  logical, parameter :: test_z17 = z17 == (1.5, 2.)
  complex, parameter :: z18 = (3., 4.) / 2
  logical, parameter :: test_z18 = z18 == (1.5, 2.)
end module


c-------------------------------------------------------------------------
c Compute machine epsilon, i.e, the smallest real or double precision
c number EPS such that (1.0 + EPS > 1.0).  This calculation is tricky
c because of the optimizations performed by some compilers, and because
c a comparison performed in registers may be done to a higher precision
c than one involving variables.  This program contains some minor
c violations of the F78 standard.
c-------------------------------------------------------------------------

	program epsilo

	real seps
	double precision deps

		write (*,*) 'Calculate Machine Epsilon ------'
		call cseps (seps)
		call cdeps (deps)
		write (*,*) '   single precision epsilon: ', seps
		write (*,*) '   double precision epsilon: ', deps

		write (*,*) ' '
		write (*,*) 'Verify Values -----'

		write (*, '(''     enter s.p. epsilon: '',$)')
		read (*,*) seps
		if (1.0 + seps .gt. 1.0) then
		    write (*,*) '     ok'
		else
		    write (*,*) '     not ok'
		endif

		write (*, '(''     enter d.p. epsilon: '',$)')
		read (*,*) deps
		if (1.0 + deps .gt. 1.0) then
		    write (*,*) '     ok'
		else
		    write (*,*) '     not ok'
		endif

		stop
	end

c -- Compute the single precision epsilon.

	subroutine cseps (seps)

	real	seps
	real	sval
	double	precision dval
	logical	sgt
	common	/eps/ sval, dval
	save	/eps/

		sval = 1.0
 10		seps = sval
		sval = sval / 2.0
		if (sgt (1.0)) then
		    goto 10
		endif
	end

c -- Is SVAL + 1.0 greater than 1.0?

	logical function sgt (value)

	real	value, sval, stemp
	double precision dval
	common	/eps/ sval, dval
	save	/eps/

		stemp = sval + 1.0
		sgt = (stemp .gt. value)
	end

c -- Compute the double precision epsilon.

	subroutine cdeps (deps)

	double	precision deps
	double	precision dval
	real	sval
	logical	dgt
	common	/eps/ sval, dval
	save	/eps/

		dval = 1.0d0
 10		deps = dval
		dval = dval / 2.0d0
		if (dgt (1.0d0)) then
		    goto 10
		endif
	end

c -- Is DVAL + 1.0 greater than 1.0?

	logical function dgt (value)

	double	precision value
	double	precision dval, dtemp
	real	sval
	common	/eps/ sval, dval
	save	/eps/

		dtemp = dval + 1.0d0
		dgt = (dtemp .gt. value)
	end


! { dg-do run }
! Test the extension of intrinsic operators
module m1
 interface operator(*)
  module procedure f1
  module procedure f2
  module procedure f3
 end interface

 interface operator(.or.)
  module procedure g1
 end interface

 interface operator(//)
  module procedure g1
 end interface

contains

 function f1(a,b) result (c)
  integer, dimension(2,2), intent(in) :: a
  integer, dimension(2), intent(in)   :: b
  integer, dimension(2)   :: c
  c = matmul(a,b)
 end function f1
 function f2(a,b) result (c)
  real, dimension(2,2), intent(in) :: a
  real, dimension(2), intent(in)   :: b
  real, dimension(2)   :: c
  c = matmul(a,b)
 end function f2
 function f3(a,b) result (c)
  complex, dimension(2,2), intent(in) :: a
  complex, dimension(2), intent(in)   :: b
  complex, dimension(2)   :: c
  c = matmul(a,b)
 end function f3

 elemental function g1(a,b) result (c)
   integer, intent(in) :: a, b
   integer :: c
   c = a + b
 end function g1

end module m1

  use m1
  implicit none

  integer, dimension(2,2) :: ai
  integer, dimension(2)   :: bi, ci
  real, dimension(2,2) :: ar
  real, dimension(2)   :: br, cr
  complex, dimension(2,2) :: ac
  complex, dimension(2)   :: bc, cc

  ai = reshape((/-2,-4,7,8/),(/2,2/)) ; bi = 3
  if (any((ai*bi) /= matmul(ai,bi))) call abort()
  if (any((ai .or. ai) /= ai+ai)) call abort()
  if (any((ai // ai) /= ai+ai)) call abort()

  ar = reshape((/-2,-4,7,8/),(/2,2/)) ; br = 3
  if (any((ar*br) /= matmul(ar,br))) call abort()

  ac = reshape((/-2,-4,7,8/),(/2,2/)) ; bc = 3
  if (any((ac*bc) /= matmul(ac,bc))) call abort()

end


subroutine flncoshd(x,y)
    implicit none
    real*8,parameter :: log2_=log(2D0)
    real*8,intent(in) :: x
    real*8,intent(out) :: y
    real*8 :: absx
    !f2py intent(in) :: x
    !f2py intent(out) :: y
    absx=abs(x)
    if(x>12) then
        y=x-log2_
    else
        y=log(cosh(x))
    endif
end subroutine flncoshd

subroutine flncoshc(x,y)
    implicit none
    complex*16,intent(in) :: x
    complex*16,intent(out) :: y
    real*8 :: xr,xi,yr
    !f2py intent(in) :: x
    !f2py intent(out) :: y
    xr=real(x)
    xi=imag(x)
    call flncoshd(xr,yr)
    y=yr+log(dcmplx(cos(xi),tanh(xr)*sin(xi)))
end subroutine flncoshc

subroutine fpop_nogroup(config,flips,wt,a,theta,ntheta,pratio,nf,nin,nhid,fh_id)
    implicit none
    integer,intent(in) :: nf,nin,nhid,fh_id
    integer,intent(in) :: config(nin),flips(nf)
    complex*16,intent(in) :: wt(nhid,nin),a(nin),theta(nhid)
    complex*16,intent(out) :: ntheta(nhid),pratio
    integer :: iflip,ci,i
    complex*16 :: y1,y0

    !f2py intent(in) :: nf,nin,nhid,config,flips,wt,a,theta,fh_id
    !f2py intent(out) :: ntheta,pratio

    ntheta=theta
    pratio=dcmplx(0D0,0D0)
    do i=1,nf
        iflip=flips(i)+1
        ci=config(iflip)
        ntheta=ntheta-2*ci*wt(:,iflip)
        pratio=pratio-2*ci*a(iflip)
    enddo
    if(fh_id==0) then
        do i=1,nhid
            y1=log(cosh(ntheta(i)))
            y0=log(cosh(theta(i)))
            pratio=pratio+y1-y0
        enddo
    elseif(fh_id==1) then
        do i=1,nhid
            y1=log(sinh(ntheta(i)))
            y0=log(sinh(theta(i)))
            pratio=pratio+y1-y0
        enddo
    elseif(fh_id==2)then
        do i=1,nhid
            call flncoshc(ntheta(i),y1)
            call flncoshc(theta(i),y0)
            pratio=pratio+y1-y0
        enddo
    else
        print*,'Error, invalid fh_id!'
        stop 2
    endif
    pratio=exp(pratio)
end subroutine fpop_nogroup


program main

   use omp_lib
   implicit none

   integer, parameter :: ITER = 50000000   ! use a smaller value if available memory is small
   integer :: i, id
   real*8 :: tdata
   integer :: sum = 0

   !$omp parallel private (i, id, tdata)
      id = omp_get_thread_num()
      tdata = omp_get_wtime()

   !$omp do reduction (+:sum) schedule(dynamic)
      do i = 2, ITER
         if (check_prime(i) == 1) sum = sum + 1
      enddo
   !$omp end do

      tdata = omp_get_wtime() - tdata

      if (id == 0) print *, "Number of prime numbers is ", &
                   & sum, "in ", tdata, " sec"
   !$omp end parallel

   contains
      integer function check_prime (num)
         implicit none
         integer, intent (in) :: num
         integer :: i, iend

         iend = int (sqrt(num*1.0))
         do i = 2, iend
            if (mod(num,i) == 0) then
                check_prime = 0
                return
            endif
         enddo

         check_prime = 1

      end function check_prime

end program main


program intel_dgemm

use,intrinsic :: iso_fortran_env, only: dp=>real64

IMPLICIT NONE (type, external)

external :: dgemm
real(dp) ALPHA, BETA
INTEGER          M, K, N, I, J
PARAMETER        (M=2000, K=200, N=1000)
real(dp), allocatable :: A(:,:), B(:,:), C(:,:)

allocate(A(M,K), B(K,N), C(M,N))

PRINT *, "Initializing data for matrix multiplication C=A*B for "
PRINT '(a,I5,a,I5,a,I5,a,I5,a,/)', " matrix A(",M," x",K, ") and matrix B(", K," x", N, ")"

ALPHA = 1
BETA = 0

PRINT *, "Intializing matrix data"
PRINT *, ""
forall (I = 1:M, J = 1:K)  A(I,J) = (I-1) * K + J

forall (I = 1:K, J = 1:N)  B(I,J) = -((I-1) * N + J)

C(:,:) = 0

PRINT *, "Computing matrix product using DGEMM subroutine"
CALL DGEMM('N','N',M,N,K,ALPHA,A,M,B,K,BETA,C,M)

PRINT *, "Top left corner of matrix A:"
PRINT '(6(F12.0,1x),/)', ((A(I,J), J = 1,MIN(K,6)), I = 1,MIN(M,6))

PRINT *, "Top left corner of matrix B:"
PRINT '(6(F12.0,1x),/)', ((B(I,J),J = 1,MIN(N,6)), I = 1,MIN(K,6))

PRINT *, "Top left corner of matrix C:"
PRINT '(6(ES12.4,1x),/)', ((C(I,J), J = 1,MIN(N,6)), I = 1,MIN(M,6))

end program


*DECK DLBETA
      DOUBLE PRECISION FUNCTION DLBETA (A, B)
C***BEGIN PROLOGUE  DLBETA
C***PURPOSE  Compute the natural logarithm of the complete Beta
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLBETA(A,B) calculates the double precision natural logarithm of
C the complete beta function for double precision arguments
C A and B.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DLBETA
      DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM,
     1  DLNREL
      EXTERNAL DGAMMA
      SAVE SQ2PIL
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
C***FIRST EXECUTABLE STATEMENT  DLBETA
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLBETA',
     +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
C
      IF (P.GE.10.D0) GO TO 30
      IF (Q.GE.10.D0) GO TO 20
C
C P AND Q ARE SMALL.
C
      DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q)
     1  + (Q-0.5D0)*DLNREL(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q))
     1  + Q*DLNREL(-P/(P+Q))
      RETURN
C
      END


C     SUBROUTINE QRBD (IPASS,Q,E,NN,V,MDV,NRV,C,MDC,NCC)
C
C  QR ALGORITHM FOR SINGULAR VALUES OF A BIDIAGONAL MATRIX.
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1973 JUN 12, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
C     THE BIDIAGONAL MATRIX
C
C                       (Q1,E2,0...    )
C                       (   Q2,E3,0... )
C                D=     (       .      )
C                       (         .   0)
C                       (           .EN)
C                       (          0,QN)
C
C                 IS PRE AND POST MULTIPLIED BY
C                 ELEMENTARY ROTATION MATRICES
C                 RI AND PI SO THAT
C
C                 RK...R1*D*P1**(T)...PK**(T) = DIAG(S1,...,SN)
C
C                 TO WITHIN WORKING ACCURACY.
C
C  1. EI AND QI OCCUPY E(I) AND Q(I) AS INPUT.
C
C  2. RM...R1*C REPLACES 'C' IN STORAGE AS OUTPUT.
C
C  3. V*P1**(T)...PM**(T) REPLACES 'V' IN STORAGE AS OUTPUT.
C
C  4. SI OCCUPIES Q(I) AS OUTPUT.
C
C  5. THE SI'S ARE NONINCREASING AND NONNEGATIVE.
C
C     THIS CODE IS BASED ON THE PAPER AND 'ALGOL' CODE..
C REF..
C  1. REINSCH,C.H. AND GOLUB,G.H. 'SINGULAR VALUE DECOMPOSITION
C     AND LEAST SQUARES SOLUTIONS' (NUMER. MATH.), VOL. 14,(1970).
C
C     ------------------------------------------------------------------
      SUBROUTINE QRBD (IPASS,Q,E,NN,V,MDV,NRV,C,MDC,NCC)
C     ------------------------------------------------------------------
      integer MDC, MDV, NCC, NN, NRV
C     double precision C(MDC,NCC), E(NN), Q(NN),V(MDV,NN)
      double precision C(MDC,*  ), E(* ), Q(* ),V(MDV,* )
      integer I, II, IPASS, J, K, KK, L, LL, LP1, N, N10, NQRS
      double precision CS, DIFF, DNORM, F, G, H, SMALL
      double precision ONE, SN, T, TEMP, TWO, X, Y, Z, ZERO

      logical WNTV ,HAVERS,FAIL
      parameter(ONE = 1.0d0, TWO = 2.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      N=NN
      IPASS=1
      IF (N.LE.0) RETURN
      N10=10*N
      WNTV=NRV.GT.0
      HAVERS=NCC.GT.0
      FAIL=.FALSE.
      NQRS=0
      E(1)=ZERO
      DNORM=ZERO
           DO 10 J=1,N
   10      DNORM=max(abs(Q(J))+abs(E(J)),DNORM)
           DO 200 KK=1,N
           K=N+1-KK
C
C     TEST FOR SPLITTING OR RANK DEFICIENCIES..
C         FIRST MAKE TEST FOR LAST DIAGONAL TERM, Q(K), BEING SMALL.
   20       IF(K.EQ.1) GO TO 50
            IF(DIFF(DNORM+Q(K),DNORM) .ne. ZERO) go to 50
C
C     SINCE Q(K) IS SMALL WE WILL MAKE A SPECIAL PASS TO
C     TRANSFORM E(K) TO ZERO.
C
           CS=ZERO
           SN=-ONE
                DO 40 II=2,K
                I=K+1-II
                F=-SN*E(I+1)
                E(I+1)=CS*E(I+1)
                CALL G1 (Q(I),F,CS,SN,Q(I))
C         TRANSFORMATION CONSTRUCTED TO ZERO POSITION (I,K).
C
                IF (.NOT.WNTV) GO TO 40
                     DO 30 J=1,NRV
C
C                          Apply procedure G2 (CS,SN,V(J,I),V(J,K))
C
                        TEMP = V(J,I)
                        V(J,I) = CS*TEMP + SN*V(J,K)
                        V(J,K) =-SN*TEMP + CS*V(J,K)
   30                continue
C              ACCUMULATE RT. TRANSFORMATIONS IN V.
C
   40           CONTINUE
C
C         THE MATRIX IS NOW BIDIAGONAL, AND OF LOWER ORDER
C         SINCE E(K) .EQ. ZERO..
C
   50           DO 60 LL=1,K
                  L=K+1-LL
                  IF(DIFF(DNORM+E(L),DNORM) .eq. ZERO) go to 100
                  IF(DIFF(DNORM+Q(L-1),DNORM) .eq. ZERO) go to 70
   60           CONTINUE
C     THIS LOOP CAN'T COMPLETE SINCE E(1) = ZERO.
C
           GO TO 100
C
C         CANCELLATION OF E(L), L.GT.1.
   70      CS=ZERO
           SN=-ONE
                DO 90 I=L,K
                F=-SN*E(I)
                E(I)=CS*E(I)
                IF(DIFF(DNORM+F,DNORM) .eq. ZERO) go to 100
                CALL G1 (Q(I),F,CS,SN,Q(I))
                IF (HAVERS) then
                     DO 80 J=1,NCC
C
C                          Apply procedure G2 ( CS, SN, C(I,J), C(L-1,J)
C
                        TEMP = C(I,J)
                        C(I,J)   = CS*TEMP + SN*C(L-1,J)
                        C(L-1,J) =-SN*TEMP + CS*C(L-1,J)
   80                continue
                endif
   90           CONTINUE
C
C         TEST FOR CONVERGENCE..
  100      Z=Q(K)
           IF (L.EQ.K) GO TO 170
C
C         SHIFT FROM BOTTOM 2 BY 2 MINOR OF B**(T)*B.
           X=Q(L)
           Y=Q(K-1)
           G=E(K-1)
           H=E(K)
           F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(TWO*H*Y)
           G=sqrt(ONE+F**2)
           IF (F .ge. ZERO) then
              T=F+G
           else
              T=F-G
           endif
           F=((X-Z)*(X+Z)+H*(Y/T-H))/X
C
C         NEXT QR SWEEP..
           CS=ONE
           SN=ONE
           LP1=L+1
                DO 160 I=LP1,K
                G=E(I)
                Y=Q(I)
                H=SN*G
                G=CS*G
                CALL G1 (F,H,CS,SN,E(I-1))
                F=X*CS+G*SN
                G=-X*SN+G*CS
                H=Y*SN
                Y=Y*CS
                IF (WNTV) then
C
C              ACCUMULATE ROTATIONS (FROM THE RIGHT) IN 'V'
C
                     DO 130 J=1,NRV
C
C                          Apply procedure G2 (CS,SN,V(J,I-1),V(J,I))
C
                        TEMP = V(J,I-1)
                        V(J,I-1) = CS*TEMP + SN*V(J,I)
                        V(J,I)   =-SN*TEMP + CS*V(J,I)
  130                continue
                endif
                CALL G1 (F,H,CS,SN,Q(I-1))
                F=CS*G+SN*Y
                X=-SN*G+CS*Y
                IF (HAVERS) then
                     DO 150 J=1,NCC
C
C                          Apply procedure G2 (CS,SN,C(I-1,J),C(I,J))
C
                        TEMP = C(I-1,J)
                        C(I-1,J) = CS*TEMP + SN*C(I,J)
                        C(I,J)   =-SN*TEMP + CS*C(I,J)
  150                continue
                endif
C
C              APPLY ROTATIONS FROM THE LEFT TO
C              RIGHT HAND SIDES IN 'C'..
C
  160           CONTINUE
           E(L)=ZERO
           E(K)=F
           Q(K)=X
           NQRS=NQRS+1
           IF (NQRS.LE.N10) GO TO 20
C          RETURN TO 'TEST FOR SPLITTING'.
C
           SMALL=ABS(E(K))
           I=K
C          IF FAILURE TO CONVERGE SET SMALLEST MAGNITUDE
C          TERM IN OFF-DIAGONAL TO ZERO.  CONTINUE ON.
C      ..
                DO 165 J=L,K
                TEMP=ABS(E(J))
                IF(TEMP .EQ. ZERO) GO TO 165
                IF(TEMP .LT. SMALL) THEN
                     SMALL=TEMP
                     I=J
                end if
  165           CONTINUE
           E(I)=ZERO
           NQRS=0
           FAIL=.TRUE.
           GO TO 20
C     ..
C     CUTOFF FOR CONVERGENCE FAILURE. 'NQRS' WILL BE 2*N USUALLY.
  170      IF (Z.GE.ZERO) GO TO 190
           Q(K)=-Z
           IF (WNTV) then
                DO 180 J=1,NRV
  180           V(J,K)=-V(J,K)
           endif
  190      CONTINUE
C         CONVERGENCE. Q(K) IS MADE NONNEGATIVE..
C
  200      CONTINUE
      IF (N.EQ.1) RETURN
           DO 210 I=2,N
           IF (Q(I).GT.Q(I-1)) GO TO 220
  210      CONTINUE
      IF (FAIL) IPASS=2
      RETURN
C     ..
C     EVERY SINGULAR VALUE IS IN ORDER..
  220      DO 270 I=2,N
           T=Q(I-1)
           K=I-1
                DO 230 J=I,N
                IF (T.GE.Q(J)) GO TO 230
                T=Q(J)
                K=J
  230           CONTINUE
           IF (K.EQ.I-1) GO TO 270
           Q(K)=Q(I-1)
           Q(I-1)=T
           IF (HAVERS) then
                DO 240 J=1,NCC
                T=C(I-1,J)
                C(I-1,J)=C(K,J)
  240           C(K,J)=T
           endif

  250      IF (WNTV) then
                DO 260 J=1,NRV
                T=V(J,I-1)
                V(J,I-1)=V(J,K)
  260           V(J,K)=T
           endif
  270      CONTINUE
C         END OF ORDERING ALGORITHM.
C
      IF (FAIL) IPASS=2
      RETURN
      END


  subroutine mat_mul(nmatdim,A,B,C)
     ! Performs matrix-matrix multiply,
     ! C=A*B

     use para, only : Dp
      implicit none

     integer,intent(in) :: nmatdim

     complex(Dp) :: ALPHA
     complex(Dp) :: BETA

     complex(Dp), intent(in)  :: A(nmatdim ,nmatdim)
     complex(Dp), intent(in)  :: B(nmatdim ,nmatdim)
     !complex(Dp) :: mat_mul(nmatdim,nmatdim)
     complex(Dp), intent(out) :: C(nmatdim,nmatdim)

     ALPHA=1.0d0
     BETA=0.0D0

     C(:,:)=(0.0d0,0.0d0)

     call ZGEMM('N','N',nmatdim,nmatdim,nmatdim,ALPHA, &
               &  A,nmatdim,B,nmatdim,BETA,C,nmatdim)

     return
  end subroutine mat_mul

  subroutine zgesvd_pack(M, A, U, S, VT)
  !> ZGESVD computes the singular value decomposition (SVD) for GE matrices,
  !> In this pack, we assume the matrix A is a square matrix, the dimension
  !> of row and column are the same
  !> A = U * SIGMA * conjugate-transpose(V),
  !> VT= conjugate-transpose(V)

     use para, only : Dp
     implicit none

     integer, intent(in) :: M
     complex(dp), intent(inout) :: A(M, M)
     complex(dp), intent(out) :: U(M, M)
     real(dp)   , intent(out) :: S(M, M)
     complex(dp), intent(out) :: VT(M, M)

     character :: JOBU
     character :: JOBVT
     integer :: N
     integer :: LDA
     integer :: LDU
     integer :: LDVT
     integer :: LWORK
     real(dp), allocatable :: RWORK(:)
     complex(dp), allocatable :: WORK(:)
     integer :: INFO

     N= M
     LDA= M
     LDU= M
     LDVT= M
     allocate(RWORK(5*M))

     allocate(work(5*M))

     JOBU= 'A'
     JOBVT= 'A'

     LWORK = -1
     call zgesvd (JOBU, JOBVT, M, N, A, LDA, S, U, LDU, &
        VT, LDVT, WORK, LWORK, RWORK, INFO)
     if (INFO==0 .and. real(WORK(1))>0 )then
        LWORK= WORK(1)
        deallocate(work)
        allocate(WORK(LWORK))
     else
        write(*, *)'something wrong with zgesvd'
     endif

     call zgesvd (JOBU, JOBVT, M, N, A, LDA, S, U, LDU, &
        VT, LDVT, WORK, LWORK, RWORK, INFO)
     if (INFO /= 0) write(*, *)'something wrong with zgesvd'

     return
  end subroutine zgesvd_pack

  subroutine zhpevx_pack(mat,ndim,eig,rot)
    ! Diagonalize the ndim x ndim  hermitian matrix 'mat' and
    ! return the eigenvalues 'eig' and the unitary rotation 'rot'

    use para, only : dp, stdout

    integer, intent(in)           :: ndim
    complex(dp), intent(in)  :: mat(ndim,ndim)
    real(dp), intent(out)    :: eig(ndim)
    complex(dp), intent(out) :: rot(ndim,ndim)

    complex(dp), allocatable :: mat_pack(:),cwork(:)
    real(dp), allocatable    :: rwork(:)
    integer            :: i,j,info,nfound
    integer, allocatable :: iwork(:),ifail(:)

    allocate(mat_pack((ndim*(ndim+1))/2))
    allocate(cwork(2*ndim))
    allocate(rwork(7*ndim))
    allocate(iwork(5*ndim))
    allocate(ifail(ndim))
    do j=1,ndim
       do i=1,j
          mat_pack(i+((j-1)*j)/2)=mat(i,j)
       enddo
    enddo
    rot=0d0;eig=0.0_dp;cwork=0d0;rwork=0.0_dp;iwork=0
    call ZHPEVX('V','A','U',ndim,mat_pack,0.0_dp,0.0_dp,0,0,-1.0_dp, &
         nfound,eig(1),rot,ndim,cwork,rwork,iwork,ifail,info)
    if(info < 0) then
       write(stdout,'(a,i3,a)') 'THE ',-info,&
            ' ARGUMENT OF ZHPEVX HAD AN ILLEGAL VALUE'
       stop 'Error in zhpevx_pack'
    endif
    if(info > 0) then
       write(stdout,'(i3,a)') info,' EIGENVECTORS FAILED TO CONVERGE'
       stop 'Error in zhpevx_pack'
    endif

    return
  end subroutine zhpevx_pack


! { dg-do run }

program bug
  ! Bug triggered with at least three elements
  integer, parameter :: asize = 3

  double precision,save :: ave(asize)
  double precision,save :: old(asize)
  double precision,save :: tmp(asize)

  ave(:) = 10.d0
  old(:) = 3.d0
  tmp(:) = 0.d0

  call buggy(2.d0,asize,ave,old,tmp)
  if (any (tmp(:) .ne. 3.5)) STOP 1
end

subroutine buggy(scale_factor, asize, ave, old, tmp)

  implicit none
  ! Args
  double precision scale_factor
  integer asize
  double precision ave(asize)
  double precision old(asize)
  double precision tmp(asize)

  ! Local
  integer i

  do i = 1, asize
    tmp(i) = ave(i) - old(i)
    old(i) = ave(i)
    tmp(i) = tmp(i) / scale_factor
  end do

end subroutine buggy


    PROGRAM Testo
     USE Integer_Complex_Arithmetic
     IMPLICIT NONE
     TYPE(INTCOMPLEX) :: var1, var2, ans

     var1 = 3
     PRINT*, "var1 = 3"
     CALL Put_INTCOMPLEX(var1)
     PRINT*, ""

     var1 = 6.0
     PRINT*, "var1 = 6.0"
     CALL Put_INTCOMPLEX(var1)
     PRINT*, ""

     var1 = 6.2
     PRINT*, "var1 = 6.2"
     CALL Put_INTCOMPLEX(var1)
     PRINT*, ""

     var1 = 6.6
     PRINT*, "var1 = 6.6"
     CALL Put_INTCOMPLEX(var1)
     PRINT*, ""

     var1 = Setup_INTCOMPLEX(1,2)
     var2 = Setup_INTCOMPLEX(3,4)

     PRINT*, "(1,2)+(3,4)"
     ans = var1 + var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(1,2)-(3,4)"
     ans = var1 - var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(1,2)/(3,4)"
     ans = var1 / var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(3,4)/(3,4)"
     ans = var2 / var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(3,4)/(1,2)"
     ans = var2 / var1
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(1,2)*(3,4)"
     ans = var1 * var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "(1,2)**3"
     ans = var1 ** 3
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "+(1,2)"
     ans = +var1
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "-(1,2)"
     ans = -var1
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

     PRINT*, "Type in the two INTCOMPLEX components"
     CALL Get_INTCOMPLEX(var1)
     PRINT*, ""
     PRINT*, "This is what was typed in"
     CALL Put_INTCOMPLEX(var1)
     PRINT*, ""

     PRINT*, "Your number/(3,4)"
     ans = var1 / var2
     CALL Put_INTCOMPLEX(ans)
     PRINT*, ""

! Intrinsics

     PRINT*, "REAL(3,4)"
     PRINT*, REAL(var2)
     PRINT*, ""

     PRINT*, "INT(3,4)"
     PRINT*, INT(var2)
     PRINT*, ""

     PRINT*, "AIMAG(3,4)"
     PRINT*, AIMAG(var2)
     PRINT*, ""

     PRINT*, "CONJG(3,4)"
     CALL Put_INTCOMPLEX(CONJG(var2))
     PRINT*, ""

     PRINT*, "ABS(3,4)"
     PRINT*, ABS(var2)

    END PROGRAM Testo