      REAL FUNCTION UNIFL()
      IMPLICIT NONE

*     High quality pseudo random number generator.

*     This pseudo random generator is fully based on FUNCTION UNIFL
*     in the second edition (1987) of Bratley et al. (see below).
*     A logical INIT has been added to the original program in order
*     to include seeds in the program (implicit initialization).

*     This generator is of the so called combined type. It does
*     not behave pathologically with the Box-Muller method for the
*     generation of normal variates, as do the commonly used linear
*     congruential generators (see also comments in FUNCTION BOXMUL).

*     The algorithm is:  X(i+1) = 40014 * X(i) mod (2147483563)
*                        Y(i+1) = 40692 * Y(i) mod (2147483399)
*                        Z(i+1) = (X(i+1)+Y(i+1)) mod (2147483563)
*     The random number returned is constructed dividing Z by its
*     range. The period of the generator is about 2.30584E+18.
*     The algorithm originates from L'Ecuyer (1986). In Bratley
*     et al.(page 332) more information can be found on seeds
*     and periods of X and Y.

*     References:
*     Bratley, P., B.L. Fox, L.E. Schrage. 1983. A guide to simulation
*         Springer-Verlag New York Inc. 397 pp.
*     L'Ecuyer,P. (1986). Efficient and portable combined pseudo-
*         random number generators. Commun. ACM.

*     FORMAL_PARAMETERS:
*     none

**    local variables
      INTEGER JX,K
      DIMENSION JX(3)
      LOGICAL INIT
      SAVE
      DATA INIT/.FALSE./

      IF (.NOT.INIT) THEN
*        initialize generator ; see for seeds Bratley (1983)
         JX(2) = 1122334455
         JX(3) = 1408222472
         INIT = .TRUE.
      END IF

*     get next term in first stream = 40014 * JX(2) mod 2147483563
      K = JX(2) / 53668
      JX(2) = 40014 * (JX(2) - K * 53668)  -  K * 12211
      IF (JX(2).LT.0)  JX(2) = JX(2) + 2147483563

*     get next term in the second stream = 40692 * JX(3) mod 2147483399
      K = JX(3) / 52774
      JX(3) = 40692 * (JX(3) - K * 52774)  -  K * 3791
      IF (JX(3).LT.0)  JX(3) = JX(3) + 2147483399

*     set JX(1) = ((JX(3) + 2147483562 - JX(2)) mod 2147483562) + 1
      K = JX(3) - JX(2)
      IF (K.LE.0)  K = K + 2147483562
      JX(1) = K

*     put it on the interval (0,1)
      UNIFL = K * 4.656613E-10

      RETURN
      END


	FUNCTION PS_KINX  ( t850, t700, t500, td850, td700 )
C************************************************************************
C* PS_KINX 								*
C*									*
C* This function computes the K index:					*
C*                                                                      *
C*      KINX = ( T850 - T500 ) + TD850 - ( T700 - TD700 )		*
C*                                                                      *
C* REAL PS_KINX ( T850, T700, T500, TD850, TD700 )             		*
C*									*
C* Input parameters:							*
C*	T850		REAL		850 mb temperature in Celsius	*
C*	T700		REAL		700 mb temperature in Celsius	*
C*	T500		REAL		500 mb temperature in Celsius	*
C*	TD850		REAL		850 mb dewpoint in Celsius	*
C*	TD700		REAL		700 mb dewpoint in Celsius	*
C*									*
C* Output parameters:							*
C*	PS_KINX		REAL		K index				*
C**	                                                                *
C* Log:									*
C* P. Kocin/CSC		1980    Originally called PR_K			*
C* M. Goodman/RDS	8/84	Modified prologue and renamed		*
C* M. desJardins/GSFC	9/84	Corrected errors; changed to Celsius	*
C* M. desJardins/GSFC	3/88	Documentation				*
C************************************************************************
        INCLUDE        'GEMPRM.PRM'
        INCLUDE        'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( t850 ) .or. ERMISS ( t700 ) .or.
     +	      ERMISS ( t500 ) .or. ERMISS ( td850 ) .or.
     +	      ERMISS ( td700 ) )  THEN
	    PS_KINX = RMISSD
	  ELSE
	    PS_KINX = ( t850 - t500 ) + td850 - ( t700 - td700 )
	END IF
C*
	RETURN
	END


! { dg-do run }
! { dg-require-effective-target fortran_large_int }

program foo
   implicit none
   integer,parameter :: k = selected_int_kind (range (0_8) + 1)

   integer(kind=k), dimension(10) :: i_k
   integer(kind=k), dimension (2, 3) :: a_k
   integer(kind=k), dimension (2, 2, 3) :: b_k
   character (len=200) line1, line2, line3

   a_k = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k/), (/2, 3/))
   b_k = spread (a_k, 1, 2)
   if (any (b_k .ne. reshape ((/1_k, 1_k, 2_k, 2_k, 3_k, 3_k, 4_k, 4_k, 5_k, 5_k, 6_k, 6_k/), &
                            (/2, 2, 3/)))) &
      STOP 1
   line1 = ' '
   write(line1, 9000) b_k
   line2 = ' '
   write(line2, 9000) spread (a_k, 1, 2)
   if (line1 /= line2) STOP 2
   line3 = ' '
   write(line3, 9000) spread (a_k, 1, 2) + 0_k
   if (line1 /= line3) STOP 3
   i_k = spread(1_k,1,10)
   if (any(i_k /= 1_k)) STOP 4

9000 format(12I3)

end program


MODULE test_functions
IMPLICIT NONE
CONTAINS
  REAL FUNCTION func1(x)
  IMPLICIT NONE
  REAL, INTENT(IN) :: x
  func1 = x**2 - 2 * x + 4
  END FUNCTION func1

  REAL FUNCTION func2(x)
  IMPLICIT NONE
  REAL, INTENT(IN) :: x
  func2 = EXP(-x / 5) * SIN(2 * x)
  END FUNCTION func2

  REAL FUNCTION func3(x)
  IMPLICIT NONE
  REAL, INTENT(IN) :: x
  func3 = COS(x)
  END FUNCTION func3
END MODULE test_functions

PROGRAM test_function_pointers
USE test_functions
IMPLICIT NONE
INTEGER :: index
PROCEDURE(func1), POINTER :: p
REAL :: x
WRITE(*, *) 'Select a function to associate with the pointer:'
WRITE(*, *) ' 1: func1'
WRITE(*, *) ' 2: func2'
WRITE(*, *) ' 3: func3'
READ(*, *) index
IF ((index < 1) .OR. (index > 3)) THEN
  WRITE(*, *) 'Invalid selection.'
  ERROR STOP 'Bad index'
ELSE
  SELECT CASE(index)
    CASE(1)
      WRITE(*, *) 'func1 selected...'
      p => func1
    CASE(2)
      WRITE(*, *) 'func2 selected...'
      p => func2
    CASE(3)
      WRITE(*, *) 'func3 selected...'
      p => func3
  END SELECT
  WRITE(*, '(A)', ADVANCE='NO') 'Enter x: '
  READ(*, *) x
  WRITE(*, '(A,F13.6)') 'f(x) = ', p(x)
END IF
END PROGRAM test_function_pointers


      PROGRAM xgasdev
C     driver for routine gasdev
      INTEGER N,NP1,NOVER2,NPTS,ISCAL,LLEN
      PARAMETER(N=20,NP1=N+1,NOVER2=N/2,NPTS=10000,ISCAL=400,LLEN=50)
      INTEGER i,idum,j,k,klim
      REAL gasdev,x,dist(NP1)
      CHARACTER text(50)*1
      idum=-13
      do 11 j=1,NP1
        dist(j)=0.0
11    continue
      do 12 i=1,NPTS
        j=nint(0.25*N*gasdev(idum))+NOVER2+1
        if ((j.ge.1).and.(j.le.NP1)) dist(j)=dist(j)+1
12    continue
      write(*,'(1x,a,i6,a)')
     *     'Normally distributed deviate of ',NPTS,' points'
      write(*,'(1x,t6,a,t14,a,t23,a)') 'x','p(x)','graph:'
      do 15 j=1,NP1
        dist(j)=dist(j)/NPTS
        do 13 k=1,50
          text(k)=' '
13      continue
        klim=int(ISCAL*dist(j))
        if (klim.gt.LLEN) klim=LLEN
        do 14 k=1,klim
          text(k)='*'
14      continue
        x=float(j)/(0.25*N)
        write(*,'(1x,f7.2,f10.4,4x,50a1)')
     *       x,dist(j),(text(k),k=1,50)
15    continue
      END

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


PROGRAM Recursion_Or_Iteration
    INTEGER :: iteration
    REAL :: recursion

    iteration = 0

    DO i = 1, 10
        iteration = iteration + i
    END DO

    recursion = recu(10)

    Print *, 'Iteration : ', iteration
    Print *, 'Recursion : ', recursion
    ! Iteration :           55
    ! Recursion :    55.0000000
END PROGRAM Recursion_Or_Iteration

REAL RECURSIVE FUNCTION recu(N) RESULT(N_recu)
    INTEGER, INTENT(IN) :: N

    IF (N > 0) THEN
        N_recu = N + recu(N - 1)

    ELSE
        N_recu = 0

    END IF
END FUNCTION recu


program poisson_mpi
	use poisson_module
	use mpi
	implicit none

	integer :: i,j,k,ret
	integer :: id1,id2,id3,id4,id5
	real, allocatable, dimension(:) :: u,u0,f
	integer, allocatable, dimension(:) :: buf
	real :: h, l2
	integer :: prank, psize, ierror, tag, status(MPI_STATUS_SIZE)
	double precision :: t_start, t_end
	integer :: n_loc, offset;
	integer :: i_start, i_end

! Initialization of the MPI library
	call MPI_INIT(ierror)
	call MPI_COMM_RANK(MPI_COMM_WORLD, prank, ierror)
	call MPI_COMM_SIZE(MPI_COMM_WORLD, psize, ierror)

	h = 1. / (N+1)
! Divide n in psize and distribute the excess to the (n % psize) proc
	if (prank < mod((N+1),psize)) then
		n_loc = ((N+1) / psize) + 1
	else
		n_loc = ((N+1) / psize)
	endif
! Computing the offset of where in the global array the local array is
! located. (this is needed to initialize f) It could be computed locally
! without communication but this way you see a Allgather
	allocate(buf(psize))
	call MPI_ALLGATHER(n_loc, 1, MPI_INT, buf, 1, MPI_INT, MPI_COMM_WORLD,ierror)
	offset = 0
	do i = 1, prank
		offset = offset + buf(i)
	enddo
! add 2 for north and south ghost
	n_loc = n_loc + 2

	allocate(u((N+1)*n_loc),u0((N+1)*n_loc),f((N+1)*n_loc))

	u = 0.
	u0 = 0.
	do i = 2, N
		do j = 2, n_loc
			id1 = id(n_loc,i,j)
			f(id1) = -2.*100. * M_PI * M_PI * sin(10.*M_PI*(i-1)*h) * sin(10.*M_PI*(j-1)*h)
		enddo
	enddo

	k = 0
	l2 = 1.
	t_start = MPI_WTIME()

!	do while (l2 > eps)
	do while (k < 10)
		l2 = 0.
		i_start = 0
		i_end = 0

!    if(prank > 0) { // send recv with top proc
!      MPI_Sendrecv(uo[1], n, MPI_FLOAT, prank - 1, NORTH,
!                   uo[0], n, MPI_FLOAT, prank - 1, SOUTH, MPI_COMM_WORLD, &status);
!    } else {
!      ++i_start;
!    }
!
!    if(prank < psize - 1) { // send recv with bottom proc
!      MPI_Sendrecv(uo[n_loc - 2], n, MPI_FLOAT, prank + 1, SOUTH,
!                   uo[n_loc - 1], n, MPI_FLOAT, prank + 1, NORTH, MPI_COMM_WORLD, &status);
!    } else {
!      --i_end;
!    }

! send recv with top proc
		if (prank > 0)  then
			call MPI_SENDRECV(u0(1:N+1), (N+1), MPI_FLOAT, prank - 1, NORTH, u0(1:N+1), (N+1), MPI_FLOAT, prank - 1, SOUTH, MPI_COMM_WORLD, status, ierror)
		else
			i_start = i_start + 1
		endif

! send recv with bottom proc
		if(prank < psize - 1) then
			call MPI_SENDRECV(u0(n_loc - 2), (N+1), MPI_FLOAT, prank + 1, SOUTH, u0(n_loc - 1), (N+1), MPI_FLOAT, prank + 1, NORTH, MPI_COMM_WORLD, status, ierror)
		else
			i_end = i_end - 1
		endif

		do i = i_start, i_end
			do j = 2, N
				id1 = id(N,i,j)
				id2 = id(N,i-1,j)
				id3 = id(N,i+1,j)
				id4 = id(N,i,j-1)
				id5 = id(N,i,j+1)
				u(id1) = 0.25 * ( u0(id2) + u0(id3) + u0(id4) + u0(id5) - f(id1)*h*h);
				! L2 norm
				l2 = l2 + (u0(id1) - u(id1))*(u0(id1) - u(id1));
			enddo
		enddo

		if (prank.eq.0) call print_mat(u,n_loc,(N+1))

		u0 = u

! reduce the 12 norm to every proc
		call MPI_ALLREDUCE(MPI_IN_PLACE, l2, 1, MPI_FLOAT, MPI_SUM, MPI_COMM_WORLD, ierror);

		! output
		if (prank .eq. 0) then
			write(*,*) 'iteration',k,sqrt(l2),prank,i_start,i_end,'size of matrix',(N+1),n_loc
		endif
!			ret=write_to_file_binary(N,c_loc(u(1)),k,-1.,1.)
		k = k + 1
	enddo
	t_end = MPI_WTIME()
	if (prank .eq. 0) then
		write(*,*) 'T',(t_end - t_start),'[s]'
	endif

	deallocate(u,u0,f)

	call MPI_FINALIZE(ierror)

end program poisson_mpi


! { dg-do run }
! Tests the fix for PR32298, in which the scalarizer would generate
! a temporary in the course of evaluating MINLOC or MAXLOC, thereby
! setting the start of the scalarizer loop to zero.
!
! Contributed by Jens Bischoff <jens.bischoff@freenet.de>
!
PROGRAM ERR_MINLOC

   INTEGER, PARAMETER :: N = 7

   DOUBLE PRECISION, DIMENSION (N), PARAMETER :: A &
     = (/ 0.3D0, 0.455D0, 0.6D0, 0.7D0, 0.72D0, 0.76D0, 0.79D0 /)

   DOUBLE PRECISION :: B
   INTEGER          :: I, J(N), K(N)

  DO I = 1, N
    B = A(I)
    J(I) = MINLOC (ABS (A - B), 1)
    K(I) = MAXLOC (ABS (A - B), 1)
  END DO

  if (any (J .NE. (/1,2,3,4,5,6,7/))) call abort ()
  if (any (K .NE. (/7,7,1,1,1,1,1/))) call abort ()

  STOP

END PROGRAM ERR_MINLOC


module testfort
  implicit none

contains

  subroutine test_vector(vec)
    real(8), intent(inout) :: vec(:)
    integer :: k, n

    n = size(vec)

    do k = 1, n
      vec(k) = vec(k)*k
    end do
  end subroutine test_vector

  subroutine ones_1d(vec, n)
    real(8), allocatable, intent(out) :: vec(:)
    integer, intent(in) :: n
    allocate(vec(n))
    vec = 1.0d0
  end subroutine ones_1d

  subroutine ones_2d(arr, m, n)
    real(8), allocatable, intent(out) :: arr(:,:)
    integer, intent(in) :: m, n
    allocate(arr(m,n))
    arr = 1.0d0
  end subroutine ones_2d

  subroutine test_array_2d(arr)
    real(8), intent(inout) :: arr(:,:)
    integer :: k, l, m, n

    m = size(arr, 1)
    n = size(arr, 2)

    do l = 1, n
      do k = 1, m
        arr(k,l) = arr(k,l)*k*l
      end do
    end do
  end subroutine test_array_2d

end module testfort

program main
  use testfort
  implicit none

  real(8), allocatable :: y(:)
  real(8), allocatable :: z(:,:)

  integer :: k, l, m, n

  call ones_1d(y, 15)
  print *, y
  call test_vector(y)
  print *, y

  call ones_2d(z, 3, 2)
  call test_array_2d(z)
  print *, z

  m = size(z, 1)
  n = size(z, 2)

  do k = 1, m
      print *, z(k, :)
  end do

  deallocate(z)
  deallocate(y)
end program main


      subroutine eqroot(a,err,eqrt)
c
c     + + + PURPOSE + + +
c     Solves the following equation for U: 1 - exp(-u) = a*u, for
c     positive values of A less than 1, and positive values of U.
c     (If A=1, U=0).  Newton's method is used, with special
c     approximations for small values of A (A <= 0.06),  and large
c     values of A (A >= 0.999).
c
c     Results appear to be accurate to machine precision (real*4)
c     and require at most 2 iterations.
c
c     Called from DBLEX.
c     Author(s): Lane, Shirley, Lopez, and Stone
c     Reference in User Guide:
c
c     Changes:
c         1) Changed from a function to a subroutine, since it passes
c            more than one value back.
c         2) Comments re: small & large values of A, massively changed.
c         3) Since same value of A was observed repeatedly being passed
c            to routine, a check for this was added.
c
c        ******************************************************
c        *  NOTE:  THIS INDICATES THAT SOMETHING IS *WRONG*   *
c        *         THE VALUE OF 'A' SHOULD CHANGE EACH TIME!  *
c        ******************************************************
c
c         4) Most of the double precision calculations & comparisons
c            reduced to single precision.  However, 'E' must remain
c            double precision.
c         5) ax has been moved to common block ceqrot.inc jca2  8/31/93
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/11/91 to 4/22/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real a, eqrt
      integer err
c
c     + + + ARGUMENT DEFINITIONS + + +
c     a      - constant A in the equation:  1 - exp(-u) = a*u.
c              (In this routine, A = 1/ip.)
c     err    - flag. 0: equation solved.
c                    1: no solution for given A.
c     eqrt   - solution returned for U in the equation:
c                    1 - exp(-u) = a*u.
c
c     + + + COMMON BLOCKS + + +
      include 'ceqrot.inc'
c
c     + + + LOCAL VARIABLES + + +
      double precision d, e, f, r, s, u, tmpvr1
      real eqrtx
      integer loopfg
c
c     + + + LOCAL DEFINITIONS + + +
c     d      - A - F
c     e      - exp(-U)
c     f      - (1-E)/U
c     r      - A/TMPVR1
c     s      - abs(D/A) or abs(D/TMPVR1)
c     u      - See definition of A
c     eqrtx  - saved value of EQRT from prev. call
c     loopfg - Flag.  Set to exit loop.
c
c     + + + SAVES + + +
      save eqrtx
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
c******************************************************************
c
c     FOR SMALL VALUES OF 'A' (A <= 0.06):
c
c       If a = (1 - exp(-u))/u,
c     then a = 1/u - exp(-u)/u,
c      and a = 1/u - 1/(u*exp(u)).
c
c   Thus, for a large value of U (suppose U >= 15), the value of the
c   last term; ie, 1/(u*exp(u)), gets very close to zero.  In this
c   situation, "a = 1/u" is a good approximation of the original
c   equation.  (From this equation, when U is large, A is small.)
c
c       When a = 1/u,  u=1/a.
c
c   For A <= .06, the error in U computed by this approach appears
c   to be less than real*4 precision.
c
c******************************************************************
c
c     FOR LARGE VALUES OF 'A' (A >= 0.999):
c
c   The Taylor's series expansion with a remainder for exp(-u) is:
c
c       exp(-u) = 1 - u + u**2/2 - u**3/6 + r(u),
c       where "r(u)" represents the remainder of the terms in the series.
c
c   Substituting in the equation:  a = 1/u - exp(-u)/u, one gets:
c
c       a = 1/u - (1 - u + u**2/2 - u**3/6 + r(u)) / u,
c
c   which simplifies to:
c
c       a = 1 - u/2 + u**2/6 - r(u)/u.
c
c   Since  0 < r(u) < u**4/24, then   0 < r(u)/u < u**3/24.  (When
c   a=0.9991, u=0.0018.  As A gets larger, U gets smaller still.)
c   Assuming "r(u)/u" to be negligible, and solving for U yields:
c
c       u = 3/2 +/- sqrt(6a - 15/4).
c
c   For .999 <= a, the u appears to be less than real*4 precision.
c
c******************************************************************
c
c     FOR ORDINARY VALUES OF 'A' (0.06 > A > 0.999):
c
c Between .06 and .999, Newton's method is used, using starting values.
c Let f(u1)=a and u near u1.  |(a - f(u))/a|  =  |(f(u1) - f(u))/a|  =
c |f'(c)*u1/a|*|(u1 - u)/u1|, for some c between u and u1.   Since u is
c near u1, c and u1 are approximated by u. Thus for r=|a/(f'(u)*u)|, we
c have |(u - u1)/u1| ~ r*|(a - f(u))/a|. The relative error in f and  u
c are small if the relative error in f and r times this error is small.
c Evaluating f'(u) gives r = a/((u - 1)*f(u) - 1).
c
c Because of the approximations in the above,  we use 1/2 the smallest
c real*4 number in testing for convergence.
c
c******************************************************************
c
c     See if value of A has changed since last call to EQROOT.
c
c      *** L0 IF ***
      if (a.ne.ax) then
c
c       Verify that A is within the valid range of values; ie,
c       0.0 < A <= 1.0.
c
c       *** L1 IF ***
        if ((a.gt.0.0).and.(a.le.1.0)) then
c
c         Small A:  0 < A <= 0.06.  (Answer good to machine precision).
c
c         *** L2 IF ***
          if (a.le.0.06) then
            err = 0
            eqrt = 1.0 / a
c
c         Usual Case:  0.06 < A < 0.999.
c
          else if (a.lt.0.999) then
c
c           Estimate starting value for U.
c
            if (a.le.0.2) then
              u = 1.0 / a
            else if (a.le.0.5) then
              u = .968732 / a - 1.55098 * a + .431653
            else if (a.le.0.94) then
              u = 1.13243 / a - .928240 * a - .207111
            else
              u = (3.0/2.0) - sqrt(6.0*a-(15.0/4.0))
            end if
c
c           Iterate.
c
c           *** Begin L3 LOOP ***
            loopfg = 0
   10       continue
            e = exp(-u)
            f = (1.d0-e) / u
            d = a - f
            tmpvr1 = ((u+1.d0)*f-1.d0)
            r = a / tmpvr1
c
            if (r.le.1.d0) then
              s = abs(d/a)
            else
              s = abs(d/tmpvr1)
            end if
c
            if (s.ge.0.59e-6) then
              u = u * (1.0+d/(e-f))
            else
              loopfg = 1
            end if
c
c           *** End L3 LOOP ***
            if (loopfg.eq.0) go to 10
c
c           Exit with solution.
c
c20         err=0
            err = 0
            eqrt = sngl(u)
c
c         Large A: 0.999 <= A < 1. (Answer good to about 10 places).
c
          else if (a.lt.1.0) then
            err = 0
            eqrt = (3.0/2.0) - sqrt(6.0*a-(15.0/4.0))
c
c         Special Case: A=1 (exact limiting solution).
c
          else
            err = 0
            eqrt = 0.
c
c         *** L2 ENDIF ***
          end if
c
c         Save values of A & EQRT.
c
c         AXCCCC not used  12-16-93 02:03pm  sjl
c
c         axcccc = a
          eqrtx = eqrt
c
c       Error: A outside range.  A <= 0  or  A > 1.
c
c       *** L1 ELSE ***
        else
          err = 1
c
c       *** L1 ENDIF ***
        end if
c
c     Value of 'A' same as last time EQROOT was called.
c
c     *** L0 ELSE ***
      else
        eqrt = eqrtx
c
c     *** L0 ENDIF ***
      end if
c
      return
      end


PROGRAM test_plot
!
!  Purpose:
!    Program to test subroutine "plot".  This program generates
!    a data set based on the function:
!       y(t) = 10. * EXP (-t/5) * SIN(t)
!    starting at t = 0 for 12 seconds, with a step size dt = 1/3.
!
IMPLICIT NONE

! Declare local variables:
LOGICAL :: default = .TRUE.       ! Default plot boundaries
INTEGER :: i, unit = 6
REAL :: minplt = 0.,  maxplt = 0.
INTEGER :: npts = 37
REAL, DIMENSION(0:36) :: y

! Generate function.
DO i = 0, 36
   y(i) = 10. * EXP ( -REAL(i)/15. ) * SIN ( REAL(i)/3. )
END DO

! Plot data
CALL plot ( y, npts, minplt, maxplt, default, unit )

END PROGRAM test_plot


! chk_bessel.f90 --
!     Check if the compiler support the new Bessel functions (J0, Y0, J1, Y1, Jn, Yn)
!
!     Note: there is a whole list of such special functions defined for the Fortran 2008 standard, not
!     all of them are tested here
!
program chk_bessel
    implicit none

    real, dimension(4) :: x = (/ 0.1, 0.2, 1.0, 2.0 /)
    integer            :: i, n

    write( *, '(a)' ) 'Selected values for some Bessel functions of the first and second kind:'

    write( *, '(5a12)' ) 'x', 'J0', 'Y0', 'J1', 'Y1'
    do i = 1,size(x)
        write( *, '(5f12.4)' ) x(i), bessel_j0(x(i)), bessel_y0(x(i)), bessel_j1(x(i)), bessel_y1(x(i))
    enddo

    write( *, '(5a12)' ) 'x', 'J2', 'Y2', 'J3', 'Y3'
    do i = 1,size(x)
        write( *, '(5f12.4)' ) x(i), bessel_jn(2,x(i)), bessel_yn(2,x(i)), bessel_jn(3,x(i)), bessel_yn(3,x(i))
    enddo
end program chk_bessel


module hartree_screening
! Hartree screening function
use types, only: dp
use utils, only: stop_error
use feutils, only: define_connect, c2fullc2, fe2quad, get_parent_nodes, &
        phih, dphih
use solvers, only: solve_sym
implicit none
private
public hartree_y

contains

function hartree_y(k, p, xe, xiq, wtq, f) result(Yq)
! Calculates the Hartree screening function:
!   Y^k(f(r), r) = r*\int_0^oo dr' f(r') * min(r, r')^k / max(r, r')^(k+1)
! This function is calculated by solving an equivalent differential equation:
!   -Y^k'' + (k(k+1)/r^2) * Y^k = (2k+1)/r * f(r)
! with boundary conditions at 0 and oo (imposed by the above integral):
!   Y^k(0) = 0
!   Y^k'(oo) + (k/r) * Y^k(oo) = 0
! using FEM on the mesh 'xe', polynomial order 'p'. The function 'f' is given
! on the quadrature grid xiq/wtq. The Y^k(r) function is returned on the same
! quadrature grid. 'k' is the parameter of Y^k.
!
! Hint: use such quadrature xiq/wtq and such 'p', so that you can represent the
! function 'f' exactly. If for example f(r) = P^2(r) and P(r) is of order 'p',
! then use '2*p' for hartree_y().
!
! Note: If you want to solve the following radial Poisson equation:
!   V_H'' + (2/r)*V_H = -4*pi*n
!   (V_H*r)''         = -4*pi*n*r
! then V_H = Y^0(4*pi*n*r^2, r) / r
integer, intent(in) :: k, p
real(dp), intent(in) :: xe(:), xiq(:), wtq(:)
real(dp), intent(in) :: f(:,:)
real(dp) :: Yq(size(xiq), size(xe)-1)
real(dp), allocatable :: Am(:, :), bv(:), u(:), fullc(:), xin(:)
integer, allocatable :: ib(:, :), in(:, :)
integer :: Ne, Nb
Ne = size(xe)-1
allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(in(p+1, Ne), ib(p+1, Ne))
call define_connect(1, 2, Ne, p, in, ib)
Nb = maxval(ib)
allocate(Am(Nb, Nb), bv(Nb), u(Nb))
call assemble_hartree_y(k, f, xin, xe, ib, xiq, wtq, Am, bv)
! solve
u = solve_sym(Am, bv)
! transform solution to quadrature grid
allocate(fullc(maxval(in)))
call c2fullc2(in, ib, u, fullc)
call fe2quad(xe, xin, xiq, in, fullc, Yq)
end function

subroutine assemble_hartree_y(k, f_vals, xin, xe, ib, xiq, wtq, Am, bv)
! forms system equation matrices corresponding to the problem
! -u''(r) + k(k+1)/r^2 * u(r) = (2k+1)/r * f(x)
! subject to boundary conditions consistent with basis specified by ib
! Note: u(r) is the hartree Y^k(r) screening function
! The weak formulation is:
! \int u'(r)*v'(r) + k(k+1)/r^2 * u(r) v(r) \d r =
!    =\int (2k+1)/r * f(x) * v(x) \d r
! It solves the following weak formulation
integer, intent(in) :: k            ! k parameter in the equation
real(dp), intent(in):: f_vals(:,:)   ! f(x) at quadrature points:
   ! f_vals(i,j) = value at ith point in jth element
real(dp), intent(in) :: xin(:)       ! parent basis nodes
real(dp), intent(in) :: xe(:)        ! element coordinates
integer, intent(in) :: ib(:,:)       ! basis connectivity: ib(i,j) = index of
    ! basis function associated with local basis function i of element j.
    ! 0 = no associated basis fn.
real(dp), intent(in) :: xiq(:)       ! quadrature points
real(dp), intent(in) :: wtq(:)       ! quadrature weights
real(dp), intent(out) :: Am(:,:)     ! system matrix: Am c = bv
real(dp), intent(out) :: bv(:)       ! source vector: Am c = bv
integer :: Ne, Nb                ! number of elements, basis functions
integer :: p                     ! order of FE/SE basis
integer :: e                     ! element index
integer :: i,j                   ! basis fn indices
integer :: al,be                 ! "alpha", "beta": local basis fn indices
integer :: iq                    ! quadrature point index
real(dp) :: xa,xb                ! element boundary node coordinates
real(dp) :: jac                  ! Jacobian of transformation from parent
    ! coords xi in [-1,1] to coords x in [xa,xb]: x = (xb-xa)/2 xi + (xb+xa)/2
real(dp) :: phihq(size(xiq),size(xin)), dphihq(size(xiq),size(xin))   ! parent
    ! basis fns and derivs at quadrature points:
    ! phihq(i,j) = value of jth function at ith quadrature point
real(dp), dimension(size(xiq)) :: intq, aq, bq, xq

! initializations
Ne = size(ib, 2)
Nb = maxval(ib)
p = size(xin)-1
if (size(xin) /= size(ib,1)) &
    call stop_error("Error: inconsistent parent node and connectivity dimensions.")
if (size(Am,1) /= Nb .or. size(bv,1) /= Nb) &
    call stop_error("Error: size of Am and/or bv inconsistent with Nb.")
! tabulate parent basis and derivatives at quadrature points
do al = 1, p+1
   do iq = 1, size(xiq)
      phihq(iq, al) = phih(xin, al, xiq(iq))
      dphihq(iq, al) = dphih(xin, al, xiq(iq))
   end do
end do
! accumulate Am matrix and bv vector
! compute lower triangle
Am = 0; bv = 0
do e = 1, Ne
   xa = xe(e)
   xb = xe(e+1)
   jac = (xb - xa)/2  ! affine mapping
   ! tabulate a(x), b(x) at quadrature points
   xq = (xiq(:)+1)/2*(xb-xa)+xa ! affine mapping
   aq = k*(k+1)/xq**2
   bq = (2*k+1)/xq
   ! compute matrix/vector elements (integrals transformed to [-1,1])
   do al = 1, p+1
      i = ib(al, e)
      if (i == 0) cycle              ! omit boundary basis fns for Dirichlet BCs
      bv(i) = bv(i) + sum(wtq*bq*f_vals(:, e)*phihq(:,al)*jac)
      do be = 1, p+1
         j = ib(be, e)
         if (j == 0) cycle           ! omit boundary basis fns for Dirichlet BCs
         if (j > i) cycle            ! compute only lower triangles
         intq = dphihq(:, al) * dphihq(:, be) / jac**2   &
                    + aq * phihq(:, al) * phihq(:, be)
         Am(i, j) = Am(i, j) + sum(wtq*intq*jac)
      end do
   end do
end do
! We add the surface integral term, which is equal to:
! k/r_max * phi(r_max)*phi(r_max)
! but phi(r_max)=1, so we only get k/r_max contribution to the last diagonal
! matrix element. Note: Using numerical tests, this correction is very
! important for smaller r_max (~70 atomic units), where it makes a difference
! on the 6th significant digit. For large r_max (~500 atomic units) it doesn't
! seem to mater much. For rmax->oo or k==0 this correction is 0.
i = ib(p+1, Ne)
if (i == 0) call stop_error("Inconsistent BC")
Am(i, i) = Am(i, i) + k / xe(Ne+1)
! fill in upper triangle
do j = 1, Nb
   do i = 1, j-1
      Am(i, j) = Am(j, i)
   end do
end do
end subroutine

end module


! Generic procedures
! Defining a generic interface to a procedure is a way of grouping procedures with similar
! functionality together under one name. Typically a generic procedure interface has a general
! name and contains a list of specific procedures with similar functionality which are implemented
! for all data types in a program.

module arithmetic_mod
    implicit none
    private
    public :: adder, subtractor, multiplier, divider

    interface adder
        procedure int_add, real_add, complex_add
    end interface adder

    interface subtractor
        procedure int_sub, real_sub, complex_sub
    end interface subtractor

    interface multiplier
        procedure int_mult, real_mult, complex_mult
    end interface multiplier

    interface divider
        procedure int_div, real_div, complex_div
    end interface divider

contains
    ! Adder Functions
    function int_add(n_1, n_2) result(sum)
        integer, intent(in) :: n_1, n_2
        integer :: sum
        sum = n_1 + n_2
    end function int_add

    function real_add(n_1, n_2) result(sum)
        real, intent(in) :: n_1, n_2
        real :: sum
        sum = n_1 + n_2
    end function real_add

    function complex_add(n_1, n_2) result(sum)
        complex, intent(in) :: n_1, n_2
        complex :: sum
        sum = n_1 + n_2
    end function complex_add

    ! Subtractor Functions
    function int_sub(n_1, n_2) result(sub)
        integer, intent(in) :: n_1, n_2
        integer :: sub
        sub = n_1 - n_2
    end function int_sub

    function real_sub(n_1, n_2) result(sub)
        real, intent(in) :: n_1, n_2
        real :: sub
        sub = n_1 - n_2
    end function real_sub

    function complex_sub(n_1, n_2) result(sub)
        complex, intent(in) :: n_1, n_2
        complex :: sub
        sub = n_1 - n_2
    end function complex_sub

    ! Multiplier Functions
    function int_mult(n_1, n_2) result(mult)
        integer, intent(in) :: n_1, n_2
        integer :: mult
        mult = n_1 * n_2
    end function int_mult

    function real_mult(n_1, n_2) result(mult)
        real, intent(in) :: n_1, n_2
        real :: mult
        mult = n_1 * n_2
    end function real_mult

    function complex_mult(n_1, n_2) result(mult)
        complex, intent(in) :: n_1, n_2
        complex :: mult
        mult = n_1 * n_2
    end function complex_mult

    ! Divider Functions
    function int_div(n_1, n_2) result(div)
        integer, intent(in) :: n_1, n_2
        integer :: div
        if ( n_2 == 0 ) then
            print "(a20)", "Zero division error!"
        else
            div = n_1 / n_2
        end if
    end function int_div

    function real_div(n_1, n_2) result(div)
        real, intent(in) :: n_1, n_2
        real :: div
        if ( n_2 == 0.0 ) then
            print "(a20)", "Zero division error!"
        else
            div = n_1 / n_2
        end if
    end function real_div

    function complex_div(n_1, n_2) result(div)
        complex, intent(in) :: n_1, n_2
        complex :: div
        div = n_1 / n_2
    end function complex_div
end module arithmetic_mod


module utilities_mod
    implicit none

    private

    public :: fisher_yates_shuffle

contains

    subroutine fisher_yates_shuffle(values)
        implicit none
        integer, dimension(:), intent(inout) :: values
        integer :: i, j, tmp
        real :: r

        do i = 1, size(values) - 1
            call random_number(r)
            j = i + floor(r*(size(values) - i + 1))
            tmp = values(i)
            values(i) = values(j)
            values(j) = tmp
        end do
    end subroutine fisher_yates_shuffle

end module utilities_mod


program P1654
    implicit none

    integer :: having, needed
    integer, dimension(10000) :: length
    integer(8) :: low, mid, high
    integer(8) :: computed
    integer :: i

    read (*, *) having, needed
    read (*, *) (length(i), i = 1, having)

    low = 1
    high = 2147483647
    do while (low <= high)
        mid = (low + high) / 2
        computed = 0
        do i = 1, having
            computed = computed + (length(i) / mid)
        end do
        if (computed >= needed) then
            low = mid + 1
        else if (computed < needed) then
            high = mid - 1
        end if
    end do

    write (*, '(I0)') ((low + high) / 2)
end program P1654


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file isothermal_pressure_func.f90
!*
!* @Isothermal, two-level temperature system function: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!===============================================================================
!
!*** 			ISOTHERMAL PRESSURE FUNCTION			     ***
!
!-------------------------------------------------------------------------------
!Function to calculate Isotherml pressure from density.
!Uses Specific heat ratio (gamma), and Global Isothermal Sound Speed (CsIso)
!written in constants module.
!
!-------------------------------------------------------------------------------
Real*8 function isotherm_p (rho)

	Use constants
	Implicit None
		Real*8, intent(in) :: rho					!Density
		Real*8 :: THigh,TLow						!Two Phase temperature
		Real*8 :: TRatio						!Scaling Ratio between minimum and maximum TEMPERATURE
		Real*8 :: T_Scale						!Scaling factor of pressure BY TEMPERATURE

	TRatio = RhoMaxSet/RhoMinSet

	THigh = TRatio
	TLow = 1.0d0

	If (TwoPhaseBool .eqv. .TRUE.) then
		If (rho.lt.RhoCrit) then
			T_Scale = THigh
		else if (rho.ge.RhoCrit) then
			T_Scale = TLow
		endif
	else
		T_Scale = 1.d0
	endif

!	Isothermal Sound Speed:
!	CsIso^2 = U*(Gamma-1)

!	Internal Energy:
!	U = (k * T)/(gamma-1)
!	U = CsIso^2 / (Gamma-1)

!	Pressure:
!	P = rho * kb * T / mu
!	P = rho*(gam-1)*U
!	P = rho * Cs^2
	isotherm_p = rho*(CsIso**2)*T_Scale

end function isotherm_p


      REAL FUNCTION VECANG (VX1,VY1,VZ1, VX2,VY2,VZ2)

C  This function accepts two 3D vectors and returns the
C  angle between them.

      REAL  VX1,VY1,VZ1, VX2,VY2,VZ2, VECL, DOTPRD, VL, COSVAL

      VL = VECL(VX1,VY1,VZ1) * VECL(VX2,VY2,VZ2)

      IF (VL .EQ. 0) THEN
         VECANG = 0.0
      ELSE
         COSVAL = DOTPRD (VX1,VY1,VZ1, VX2,VY2,VZ2) / VL
         IF (ABS(COSVAL) .GT. 1.0) THEN
            CALL UNMSG ('Unstable parameters passed to VECANG.')
         ENDIF
         VECANG = ACOS (COSVAL)
      ENDIF

      END


program echo_state_network
	implicit none

	!general constants and variables
	real (8) :: pi
	integer :: i, j, k, l
	!lorenz system
	real (8) :: sigma, r, beta
	real (8) :: dt, total_t, t
	real (8) :: x_0, y_0, z_0
	real (8), dimension (:), allocatable :: x, y, z
	integer :: steps
	!downsampling
	real (8), dimension(:,:), allocatable :: u_k
	integer :: downsample_length
	!echo state network variables, matrices
	real (8), dimension (:,:), allocatable :: w, v, x_i, Res_x, Res_y, Res_z,  y_i
	real (8) :: alpha, c, a
	real (8) :: w_sum, v_sum
	integer :: n

	!define general constants
	pi = 4.d0*datan(1.d0)

	!generate Lorenz system trajectory

	sigma = 10.d0
	r = 28.d0
	beta = 8.d0/3.d0

	x_0 = 1
	y_0 = 1
	z_0 = 1

	dt = 0.005 !seconds
	total_t = 1000 !seconds
	steps = int(total_t/dt)

	allocate(x(steps), y(steps), z(steps))

	call iterate_heun(x,y,z)

	!downsample to dt = 0.02, and combine trajectories to form u_k

	downsample_length = int(steps/4)

	allocate(u_k(3,downsample_length))

	do i = 1, downsample_length
		u_k(1,i) = x(i*4)
		u_k(2,i) = y(i*4)
		u_k(3,i) = z(i*4)
	end do

	deallocate(x, y, z)

	!generate reservoir (w) and input (v) matrices

	n = 50 !reservoir nodes

	allocate(w(n,n), v(3,n))

	call generate_reservoir_matrix(w)
	call normalize_spectral_radius(w)
	call generate_input_matrix(v)

	!define other esn components, variable, starting values, iterate esn.

	allocate(x_i(downsample_length, N))

	alpha = 0.005
	c = 1
	a = 1

	x_i = 1

	w_sum = 0
	v_sum = 0

	do l = 1, downsample_length - 1
		do i = 1, N
			do j = 1, N
				w_sum = w(j,i)*x_i(l, j)
			end do

			do k = 1, 3
				v_sum = v(k,i)*u_k(k, l)
			end do

			x_i(l+1, i)= (1-alpha)*x_i(l,i)+ &
				alpha*tanh(c*w_sum + a*v_sum)

			w_sum = 0
			v_sum = 0
		end do
	end do

	!esn readout

	open (10,file='y_i.dat')

	allocate(y_i(3, downsample_length), Res_x(downsample_length,N), &
				Res_y(downsample_length,N), Res_z(downsample_length,N))

	y_i = 0

	do i = 3000, downsample_length - 5
		do j = 1, N
			Res_x(i,j) = u_k(1, i )/x_i(i,j)
					!write(*,*) u_k(1,i+5), Res(i,j)*x_i(i,j), x_i(i,j)
		end do

	end do

	do i = 3000, downsample_length - 5
		do j = 1, N
			Res_x(i,j) = u_k(1, i + 5)/x_i(i,j)
					!write(*,*) u_k(1,i+5), Res(i,j)*x_i(i,j), x_i(i,j)
		end do

	end do

	do i = 3000, downsample_length - 5
		do j = 1, N
			Res_y(i,j) = u_k(2, i + 5)/x_i(i,j)
					!write(*,*) u_k(1,i+5), Res(i,j)*x_i(i,j), x_i(i,j)
		end do

	end do

	do i = 3000, downsample_length - 5
		do j = 1, N
			Res_z(i,j) = u_k(3, i + 5)/x_i(i,j)
					!write(*,*) u_k(1,i+5), Res(i,j)*x_i(i,j), x_i(i,j)
		end do

	end do

	do i = 3000, downsample_length
		do j = 1, N
			y_i(1,i) = y_i(1,i) + x_i(i, j)*Res_x(i,j)
			y_i(2,i) = y_i(2,i) + x_i(i, j)*Res_y(i,j)
			y_i(3,i) = y_i(3,i) + x_i(i, j)*Res_z(i,j)
		end do
		write(10,*) y_i(1,i)/50, y_i(2,i)/50, y_i(3,i)/50
	end do

	contains

	!start: lorenz and heun

	real function dot_u_1(u_1, u_2)
		real (8), intent (in) ::u_1, u_2
		dot_u_1 = sigma*(u_2 - u_1)
	end function dot_u_1

	real function dot_u_2(u_1, u_2, u_3)
		real (8) :: u_1, u_2, u_3
		dot_u_2 = u_1*(r-u_3)-u_2
	end function dot_u_2

	real function dot_u_3(u_1, u_2, u_3)
		real (8) :: u_1, u_2, u_3
		dot_u_3 = u_1*u_2 - beta*u_3
	end function dot_u_3

	subroutine iterate_heun(x, y, z)
		real (8), dimension (:), intent (inout) :: x, y, z
		real (8) :: p_kx, p_ky, p_kz, h_kx, h_ky, h_kz
		integer :: i

		h_kx = x_0
		h_ky = y_0
		h_kz = z_0

		open (10,file='trajectory.dat')

		do i = 1, steps

			p_kx = h_kx + dot_u_1(p_kx, p_ky)*dt
			p_ky = h_ky + dot_u_2(p_kx, p_ky, p_kz)*dt
			p_kz = h_kz + dot_u_3(p_kx, p_ky, p_kz)*dt

			h_kx = h_kx + (dot_u_1(h_kx, h_ky) + dot_u_1(p_kx, p_ky))*dt/2
			h_ky = h_ky + (dot_u_2(h_kx, h_ky, h_kz) + dot_u_2(p_kx, p_ky, p_kz))*dt/2
			h_kz = h_kz + (dot_u_3(h_kx, h_ky, h_kz)+ dot_u_3(p_kx, p_ky, p_kz))*dt/2

			x(i) = h_kx
			y(i) = h_ky
			z(i) = h_kz

			write(10,*) h_kx, h_ky, h_kz

		end do
		close (10)
	end subroutine iterate_heun

	!end: lorenz and huen

	!start generate reservoir (w) and input (v) matrices

	subroutine generate_reservoir_matrix(W)
		real (8), dimension (:,:), intent (inout) :: W
		real (8) :: p, weight

		w = 0
		weight = 2

		do i = 1, N
			do j = 1, N
				call random_number(p)
				if (p.lt.0.05) then
					do while (abs(weight).gt.1)
						weight =  norm_rand(0.5, 1.0)/sqrt(2*pi)

					end do
					W(i,j) = abs(weight)
					weight = 2
				end if
			end do

		end do
	end subroutine generate_reservoir_matrix

		subroutine normalize_spectral_radius(w)

		real (8), dimension(:,:), intent(inout) :: w
		character :: jobvl, jobvr
		real (8), dimension(:), allocatable :: work, wr, wi, magnitudes
		real (8), dimension(:,:), allocatable :: vr, vl, a
		integer :: n, lda, ldvl, ldvr, lwork, info, i

		a = w
		jobvl = 'N'
		jobvr = 'N'
		n = size(a,1)
		lda = n
		ldvl = n
		ldvr = n
		lwork = 10000

		allocate(wr(n), wi(n), vl(ldvl, n), &
				vr(ldvr, n), work(lwork))

		call dgeev(jobvl, jobvr, n, a, lda, wr, wi, &
						vl, ldvl, vr, ldvr, work, lwork, info)
		do i = 1, n
			magnitudes = sqrt(wr**2 + wi**2)
		end do

		w = w/maxval(magnitudes)

		end subroutine normalize_spectral_radius

		subroutine generate_input_matrix(v)
			real (8), dimension(:,:), intent (inout) :: v
			real (8) :: p, weight, num
			integer :: i, j

			v = 0

			call random_number(num)
			v(1,int(num*N)) = norm_rand(0.5, 1.0)/sqrt(2*pi)
			call random_number(num)
			v(2,int(num*N)) = norm_rand(0.5, 1.0)/sqrt(2*pi)
			call random_number(num)
			v(3,int(num*N)) = norm_rand(0.5, 1.0)/sqrt(2*pi)

			do i = 1, 3
				do j = 1, N
					call random_number(p)
					if (p.lt.0.05) then
						do while (abs(weight).gt.1)
							weight =  norm_rand(0.5, 1.0)/sqrt(2*pi)
						end do
						v(i,j) = abs(weight)
						weight = 2
					end if
				end do
			end do
	end subroutine generate_input_matrix

	! uses the marsaglia polar method to create pseudo-random number pairs that
	! have a normal distribution. The function saves one of the random numbers from
	! the generated pair as a spare to be returned for the next call to the function.
	! Returns a real scalar
	function norm_rand(mean, std_dev)
		real :: norm_rand
		real, intent(in) :: mean, std_dev
		real :: x, y, r
		real, save :: spare
		logical, save :: has_spare
		! use a spare saved from a previous run if one exists
		if (has_spare) then
			has_spare = .FALSE.
			norm_rand = mean + (std_dev * spare)
			return
		else
			r = 1.0
			do while ( r >= 1.0 )
				! generate random number pair between 0 and 1
				call random_number(x)
				call random_number(y)
				! normalise random numbers to be in square of side-length = R
				x = (x * 2.0) - 1.0
				y = (y * 2.0) - 1.0
				r = x*x + y*y
			end do

			! calculate the co-efficient to multiply random numbers x and y
			! by to achieve normal distribution
			r = sqrt((-2.0 * log(r)) / r)

			norm_rand = mean + (std_dev * x * r)
			spare = y * r
			has_spare = .TRUE.
			return
		end if
	end function norm_rand

		subroutine write_matrix(Matrix)
		real (8), dimension(:,:), intent(inout) :: Matrix
		integer :: i
		do i=1, size(Matrix, 1)
			write(*,'(20G12.4)') Matrix(i,:)
		end do
	end subroutine

end program


use dflib
use dialogm
logical::status,color_create,burn=.false.
integer(4)::color_matrix(4,8),function_matrix(0:100),fractal_type_code,palette_code
integer(4)::x_mouse,y_mouse,color(1:256),res_x,res_y,ir,max_irritation,coord_x,coord_y,function_code
real(8)::i,j,step,blowup,x,y,zoom,zarib
complex(8)::z,c,t,d_f
type (xycoord) origin
type (dialog) dlgbox
type (windowconfig) wc
!************************Main Program*****************************
! initializing screen resolution
call dialog_res(dlgbox,res_x,res_y)
wc%numxpixels=res_x
wc%numypixels=res_y
	wc%numtextcols = -1
	wc%numtextrows = -1
	wc%numcolors   = -1
	wc%title= "This is a test"C
	wc%fontsize = #0008000C
status=setwindowconfig(wc)
call setvieworg(int(res_x/2),int(res_y/2),origin)
!----------------------Color Palette Generator--------------------
call dialog_Fractal_type(dlgbox,fractal_type_code)
call dialog_function(dlgbox,function_code)
call dialog_fractal_settings(dlgbox,c,step,blowup,max_irritation,color_create,zarib)
print*,color_create
if (color_create) then
	call dialog_palette_box(dlgbox,palette_code)
	call palettes(palette_code,color_matrix,number_color)
else
	call dialog_color_palette(dlgbox,color_matrix,number_color)
end if
call color_palette(number_color,Color_matrix,color)
!-------------------------Fractal Type---------------------------------
if (fractal_type_code==10) then
	goto 10
else if (fractal_type_code==20) then
	goto 20
else if (fractal_type_code==30) then
	goto 30
else if (fractal_type_code==40) then
	goto 40
end if
!-------------------------Julia Set------------------------------------
10 zoom=step
coord_x=0
coord_y=0
do
	coord_x=coord_x+x_mouse*zoom
	coord_y=coord_y+y_mouse*zoom
	zoom=zoom/step
	call clearscreen($gclearscreen)
	do i=-res_x/2,res_x/2
		do j=-res_y/2,res_y/2
			z=cmplx((i*zoom+coord_x)/100.,(j*zoom+coord_y)/100.)
			ir=0
			a:do
				call f(z,c,t,burn,function_code)
				ir=ir+1
				call im_re(t,x,y)
				e=snormal(x,y)
				if((ir>max_irritation).or.(e>blowup)) then
					exit a
				endif
				z=t
			enddo a
			status = setpixelrgb(i,j,color(mod(ir,256)+1))
		enddo
	enddo
result=waitonmouseevent(mouse$lbuttondown,keystate,x_mouse,y_mouse)
l=l+1
x_mouse=x_mouse-res_x/2
y_mouse=y_mouse-res_y/2
end do
!------------------------Mandelbort Set----------------------------
20 zoom=step
coord_x=0
coord_y=0
do
	coord_x=coord_x+x_mouse*zoom
	coord_y=coord_y+y_mouse*zoom
	zoom=zoom/step
	call clearscreen($gclearscreen)
	do i=-res_x/2,res_x/2
		do j=-res_y/2,res_y/2
			c=cmplx((i*zoom+coord_x)/100.,(j*zoom+coord_y)/100.)
			ir=0
			z=0
			b:do
				call f(z,c,t,burn,function_code)
				ir=ir+1
				call im_re(t,x,y)
				e=snormal(x,y)
				if((ir>max_irritation).or.(e>blowup)) then
					exit b
				endif
				z=t
			enddo b
			status = setpixelrgb(i,j,color(mod(ir,256)+1))
		enddo
	enddo
	result=waitonmouseevent(mouse$lbuttondown,keystate,x_mouse,y_mouse)
	x_mouse=x_mouse-res_x/2
	y_mouse=y_mouse-res_y/2
end do
!------------------------Newton Set--------------------------------
30 zoom=step
coord_x=0
coord_y=0
do
	coord_x=coord_x+x_mouse*zoom
	coord_y=coord_y+y_mouse*zoom
	zoom=zoom/step
	call clearscreen($gclearscreen)
	do i=-res_x/2,res_x/2
		do j=-res_y/2,res_y/2
			z=cmplx((i*zoom+coord_x)/100.,(j*zoom+coord_y)/100.)
			ir=0
			hh:do
				call f(z,c,t,burn,function_code)
				ir=ir+1
				call im_re(t,x,y)
				e=snormal(dble(x),dble(y))
				if((ir>max_irritation).or.(e>blowup)) then
					exit hh
				endif
				if (t==0) then
					t=1
				end if
				call df(z,c,d_f,function_code)
				z=z-zarib*d_f/t
			enddo hh
			status = setpixelrgb(i,j,color(mod(ir,256)+1))
		enddo
	enddo
	result=waitonmouseevent(mouse$lbuttondown,keystate,x_mouse,y_mouse)
	x_mouse=x_mouse-res_x/2
	y_mouse=y_mouse-res_y/2
end do
!------------------------Burning Ship----------------------------
40 zoom=step
burn=.true.
do
	coord_x=coord_x+x_mouse*zoom
	coord_y=coord_y+y_mouse*zoom
	zoom=zoom/step
	call clearscreen($gclearscreen)
	do i=-res_x/2,res_x/2
		do j=-res_y/2,res_y/2
			c=cmplx((i*zoom+coord_x)/100.,(j*zoom+coord_y)/100.)
			ir=0
			z=0
			bs:do
				call f(z,c,t,burn,function_code)
				ir=ir+1
				call im_re(t,x,y)
				e=snormal(x,y)
				if((ir>max_irritation).or.(e>blowup)) then
					exit bs
				endif
				z=t
			enddo bs
			status = setpixelrgb(i,j,color(mod(ir,256)+1))
		enddo
	enddo
	result=waitonmouseevent(mouse$lbuttondown,keystate,x_mouse,y_mouse)
	x_mouse=x_mouse-res_x/2
	y_mouse=y_mouse-res_y/2
end do
contains
!***********************Sub Programs******************************
	subroutine im_re(a,re,im)
		complex(8)::a
		real(8)::im,re
		im=aimag(a)
		re=real(a)
	end subroutine im_re
!-----------------------------------------------------------------
	function snormal(b,c)
		real(8)::snormal,b,c
		snormal=dsqrt(dble(b)**2+dble(c)**2)
		return
	end function snormal
!------------------------Function--------------------------------------
	subroutine f(z,c,t,burn,function_code)
	complex(8)::z,c,t,bsi=(0,1)
	integer(4)::function_code
	real(8)::iim,iir
	logical::burn
	if (burn) then
		call im_re(z,iim,iir)
		z=(abs(iim)+abs(iir)*bsi)
	end if
	if (function_code==1) then
		t=z**2+c
	end if
	if (function_code==2) then
		t=z**3+c
	end if
	if (function_code==3) then
		t=z**3+z+c
	end if
	if (function_code==4) then
		t=z**3-c
	end if
	if (function_code==5) then
		t=z**2-c
	end if
	if (function_code==6) then
		t=z**4-z-c
	end if
	if (function_code==7) then
		t=z**4+c
	end if
	if (function_code==8) then
		t=z**5+c
	end if
	if (function_code==9) then
		t=z**6-z**2-c
	end if
	if (function_code==10) then
		t=z**2+3*c
	end if
	if (function_code==11) then
		t=sin(z)
	end if
	if (function_code==12) then
		t=cos(z)
	end if
	if (function_code==13) then
		t=cos(z**2)
	end if
	if (function_code==14) then
		t=(z+sqrt(z))**2+c
	end if
	if (function_code==15) then
		t=z**5+c*z**3+c
	end if
	if (function_code==16) then
		t=(z+exp(z))**2+c
	end if
	if (function_code==17) then
		t=sqrt(z**3+c)
	end if
	if (function_code==18) then
		t=z**30-30*z**29-87*z**28 + c
	end if
	if (function_code==19) then
		t=z**(4*atan(1.))+(4*atan(1.))**c
	end if
	if (function_code==20) then
		t=z**2/c
	end if
	if (function_code==21) then
		t=z**2*log(c)
	end if
	if (function_code==22) then
		t=(z*cos(z))**2+c
	end if
	if (function_code==23) then
		t=1+c
	end if
	if (function_code==24) then
		t=z**(2-z)+c
	end if
	if (function_code==25) then
		t=z**(1+sin(z)/cos(z))+c
	end if
	if (function_code==26) then
		t=c*sin(z)/cos(z)
	end if
	if (function_code==27) then
		t=c*cos(z)
	end if
	if (function_code==28) then
		t=c*sin(z)
	end if
	if (function_code==29) then
		t=c*z**2
	end if
	if (function_code==30) then
		t=(z**2-z)**2+c
	end if
	end subroutine f
!------------------------DF function-------------------------------------
	subroutine df(z,c,d_f,function_code)
		complex(8)::z,d_f,c
		integer(4)::function_code
		d_f=1
		if (d_f/=0) then
			if (function_code==1) then
				d_f=2*z
			end if
			if (function_code==2) then
				d_f=3*z**2+c
			end if
			if (function_code==3) then
				d_f=3*z**2+1
			end if
			if (function_code==4) then
				d_f=3*z**2
			end if
			if (function_code==5) then
				d_f=2*z
			end if
			if (function_code==6) then
				d_f=4*z**3-1
			end if
			if (function_code==7) then
				d_f=4*z**3
			end if
			if (function_code==8) then
				d_f=5*z**4
			end if
			if (function_code==9) then
				d_f=6*z**5-2*z
			end if
			if (function_code==10) then
				d_f=2*z
			end if
			if (function_code==11) then
				d_f=cos(z)
			end if
			if (function_code==12) then
				d_f=-sin(z)
			end if
			if (function_code==13) then
				d_f=-2*z*sin(z**2)
			end if
			if (function_code==14) then
				if (z/=0) then
					d_f=2*(z+sqrt(z))*((1./(2*sqrt(z))+1))+c
				else
					d_f=3*(z+sqrt(z))
				end if
			end if
			if (function_code==15) then
				d_f=5*z**4+3*c*z**2
			end if
			if (function_code==16) then
				d_f=2*(z+exp(z))*(1+exp(z))
			end if
			if (function_code==17) then
				if (z/=0) then
					d_f=(3*z**2)*(1./(2*sqrt(z**3+c)))
				else
					d_f=3*z**2*0.5
				end if
			end if
			if (function_code==18) then
				d_f=30*z**29-87*z**28-2349*z**27
			end if
			if (function_code==19) then
				d_f=4*atan(1.)*z**(4*atan(1.)-1)
			end if
			if (function_code==20) then
				d_f=(2./c)*z
			end if
			if (function_code==21) then
				d_f=2*z*(1./c)
			end if
			if (function_code==22) then
				d_f=2*(z*cos(z))*(1-sin(z))
			end if
			if (function_code==23) then
				if ((z/=0).and.(log(z)/=1)) then
					d_f=(1./z)*(1./sqrt(1-log(z)**2))
				end if
			end if
			if (function_code==24) then
				d_f=(2-z)*z**(1-z)
			end if
			if (function_code==25) then
				d_f=z**(sin(z)/cos(z))*(1./(1+z**2))
			end if
			if (function_code==26) then
				d_f=c*(1+(sin(z)/cos(z))**2)
			end if
			if (function_code==27) then
				d_f=c*(-sin(z))
			end if
			if (function_code==28) then
				d_f=c*cos(z)
			end if
			if (function_code==29) then
				d_f=c*2*z
			end if
			if (function_code==30) then
				d_f=2*(z**2-z)*(2*z-1)
			end if
		end if
	end subroutine df
end


      SUBROUTINE SB02SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, A, LDA, T,
     $                   LDT, U, LDU, G, LDG, Q, LDQ, X, LDX, SEPD,
     $                   RCOND, FERR, 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 estimate the conditioning and compute an error bound on the
C     solution of the real discrete-time matrix algebraic Riccati
C     equation (see FURTHER COMMENTS)
C                                 -1
C         X = op(A)'*X*(I_n + G*X)  *op(A) + Q,                      (1)
C
C     where op(A) = A or A' (A**T) and Q, G are symmetric (Q = Q**T,
C     G = G**T). The matrices A, Q and G are N-by-N and the solution X
C     is N-by-N.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'C':  Compute the reciprocal condition number only;
C             = 'E':  Compute the error bound only;
C             = 'B':  Compute both the reciprocal condition number and
C                     the error bound.
C
C     FACT    CHARACTER*1
C             Specifies whether or not the real Schur factorization of
C             the matrix Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or
C             Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C'), is supplied
C             on entry, as follows:
C             = 'F':  On entry, T and U (if LYAPUN = 'O') contain the
C                     factors from the real Schur factorization of the
C                     matrix Ac;
C             = 'N':  The Schur factorization of Ac will be computed
C                     and the factors will be stored in T and U (if
C                     LYAPUN = 'O').
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 part of the symmetric matrices Q and G is
C             to be used, as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C
C     LYAPUN  CHARACTER*1
C             Specifies whether or not the original Lyapunov equations
C             should be solved in the iterative estimation process,
C             as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix U, e.g., RHS <-- U'*RHS*U;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X, Q, and G.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of
C             this array must contain the matrix A.
C             If FACT = 'F' and LYAPUN = 'R', A is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= max(1,N), if FACT = 'N' or  LYAPUN = 'O';
C             LDA >= 1,        if FACT = 'F' and LYAPUN = 'R'.
C
C     T       (input or output) DOUBLE PRECISION array, dimension
C             (LDT,N)
C             If FACT = 'F', then T is an input argument and on entry,
C             the leading N-by-N upper Hessenberg part of this array
C             must contain the upper quasi-triangular matrix T in Schur
C             canonical form from a Schur factorization of Ac (see
C             argument FACT).
C             If FACT = 'N', then T is an output argument and on exit,
C             if INFO = 0 or INFO = N+1, the leading N-by-N upper
C             Hessenberg part of this array contains the upper quasi-
C             triangular matrix T in Schur canonical form from a Schur
C             factorization of Ac (see argument FACT).
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= max(1,N).
C
C     U       (input or output) DOUBLE PRECISION array, dimension
C             (LDU,N)
C             If LYAPUN = 'O' and FACT = 'F', then U is an input
C             argument and on entry, the leading N-by-N part of this
C             array must contain the orthogonal matrix U from a real
C             Schur factorization of Ac (see argument FACT).
C             If LYAPUN = 'O' and FACT = 'N', then U is an output
C             argument and on exit, if INFO = 0 or INFO = N+1, it
C             contains the orthogonal N-by-N matrix from a real Schur
C             factorization of Ac (see argument FACT).
C             If LYAPUN = 'R', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= 1,        if LYAPUN = 'R';
C             LDU >= MAX(1,N), if LYAPUN = 'O'.
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular part of the
C             matrix G.
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             matrix G.                     _
C             Matrix G should correspond to G in the "reduced" Riccati
C             equation (with matrix T, instead of A), if LYAPUN = 'R'.
C             See METHOD.
C
C     LDG     INTEGER
C             The leading dimension of the array G.  LDG >= max(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular part of the
C             matrix Q.
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             matrix Q.                     _
C             Matrix Q should correspond to Q in the "reduced" Riccati
C             equation (with matrix T, instead of A), if LYAPUN = 'R'.
C             See METHOD.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= max(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array must contain the
C             symmetric solution matrix of the original Riccati
C             equation (with matrix A), if LYAPUN = 'O', or of the
C             "reduced" Riccati equation (with matrix T), if
C             LYAPUN = 'R'. See METHOD.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     SEPD    (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'B', the estimated quantity
C             sepd(op(Ac),op(Ac)').
C             If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced.
C
C     RCOND   (output) DOUBLE PRECISION
C             If JOB = 'C' or JOB = 'B', an estimate of the reciprocal
C             condition number of the discrete-time Riccati equation.
C             If N = 0 or X = 0, RCOND is set to 1 or 0, respectively.
C             If JOB = 'E', RCOND is not referenced.
C
C     FERR    (output) DOUBLE PRECISION
C             If JOB = 'E' or JOB = 'B', an estimated forward error
C             bound for the solution X. If XTRUE is the true solution,
C             FERR bounds the magnitude of the largest entry in
C             (X - XTRUE) divided by the magnitude of the largest entry
C             in X.
C             If N = 0 or X = 0, FERR is set to 0.
C             If JOB = 'C', FERR is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the
C             optimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             Let LWA = N*N, if LYAPUN = 'O';
C                 LWA = 0,   otherwise,
C             and LWN = N,   if LYAPUN = 'R' and JOB = 'E' or 'B';
C                 LWN = 0,   otherwise.
C             If FACT = 'N', then
C                LDWORK  = MAX(LWA + 5*N, MAX(3,2*N*N) + N*N),
C                                                 if JOB = 'C';
C                LDWORK  = MAX(LWA + 5*N, MAX(3,2*N*N) + 2*N*N + LWN),
C                                                 if JOB = 'E' or 'B'.
C             If FACT = 'F', then
C                LDWORK  = MAX(3,2*N*N) + N*N,    if JOB = 'C';
C                LDWORK  = MAX(3,2*N*N) + 2*N*N + LWN,
C                                                 if JOB = 'E' or 'B'.
C             For good performance, LDWORK must generally be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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             > 0:  if INFO = i, i <= N, the QR algorithm failed to
C                   complete the reduction of the matrix Ac to Schur
C                   canonical form (see LAPACK Library routine DGEES);
C                   on exit, the matrix T(i+1:N,i+1:N) contains the
C                   partially converged Schur form, and DWORK(i+1:N) and
C                   DWORK(N+i+1:2*N) contain the real and imaginary
C                   parts, respectively, of the converged eigenvalues;
C                   this error is unlikely to appear;
C             = N+1:  if T has almost reciprocal eigenvalues; perturbed
C                   values were used to solve Lyapunov equations, but
C                   the matrix T, if given (for FACT = 'F'), is
C                   unchanged.
C
C     METHOD
C
C     The condition number of the Riccati equation is estimated as
C
C     cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) +
C                 norm(Pi)*norm(G) ) / norm(X),
C
C     where Omega, Theta and Pi are linear operators defined by
C
C     Omega(W) = op(Ac)'*W*op(Ac) - W,
C     Theta(W) = inv(Omega(op(W)'*X*op(Ac) + op(Ac)'X*op(W))),
C        Pi(W) = inv(Omega(op(Ac)'*X*W*X*op(Ac))),
C
C     and Ac = inv(I_n + G*X)*A (if TRANA = 'N'), or
C         Ac = A*inv(I_n + X*G) (if TRANA = 'T' or 'C').
C
C     Note that the Riccati equation (1) is equivalent to
C
C         X = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q,           (2)
C
C     and to
C         _          _                _ _ _         _
C         X = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q,               (3)
C           _           _               _
C     where X = U'*X*U, Q = U'*Q*U, and G = U'*G*U, with U the
C     orthogonal matrix reducing Ac to a real Schur form, T = U'*Ac*U.
C
C     The routine estimates the quantities
C
C     sepd(op(Ac),op(Ac)') = 1 / norm(inv(Omega)),
C
C     norm(Theta) and norm(Pi) using 1-norm condition estimator.
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [2].
C
C     REFERENCES
C
C     [1] Ghavimi, A.R. and Laub, A.J.
C         Backward error, sensitivity, and refinement of computed
C         solutions of algebraic Riccati equations.
C         Numerical Linear Algebra with Applications, vol. 2, pp. 29-49,
C         1995.
C
C     [2] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
C         DGRSVX and DMSRIC: Fortran 77 subroutines for solving
C         continuous-time matrix algebraic Riccati equations with
C         condition and accuracy estimates.
C         Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
C         Chemnitz, May 1998.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C     The accuracy of the estimates obtained depends on the solution
C     accuracy and on the properties of the 1-norm estimator.
C
C     FURTHER COMMENTS
C
C     The option LYAPUN = 'R' may occasionally produce slightly worse
C     or better estimates, and it is much faster than the option 'O'.
C     When SEPD is computed and it is zero, the routine returns
C     immediately, with RCOND and FERR (if requested) set to 0 and 1,
C     respectively. In this case, the equation is singular.
C
C     Let B be an N-by-M matrix (if TRANA = 'N') or an M-by-N matrix
C     (if TRANA = 'T' or 'C'), let R be an M-by-M symmetric positive
C     definite matrix (R = R**T), and denote G = op(B)*inv(R)*op(B)'.
C     Then, the Riccati equation (1) is equivalent to the standard
C     discrete-time matrix algebraic Riccati equation
C
C         X = op(A)'*X*op(A) -                                       (4)
C                                                -1
C             op(A)'*X*op(B)*(R + op(B)'*X*op(B))  *op(B)'*X*op(A) + Q.
C
C     By symmetry, the equation (1) is also equivalent to
C                               -1
C         X = op(A)'*(I_n + X*G)  *X*op(A) + Q.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, and
C     P.Hr. Petkov, Technical University of Sofia, March 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004,
C     July 2012, May 2020.
C
C     KEYWORDS
C
C     Conditioning, error estimates, orthogonal transformation,
C     real Schur form, Riccati equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, FOUR, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, FOUR = 4.0D+0,
     $                     HALF = 0.5D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          FACT, JOB, LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDA, LDG, LDQ, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   FERR, RCOND, SEPD
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ),  G( LDG, * ),
     $                   Q( LDQ, * ), T( LDT, * ), U( LDU, * ),
     $                   X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            JOBB, JOBC, JOBE, LOWER, LQUERY, NEEDAC,
     $                   NOFACT, NOTRNA, UPDATE
      CHARACTER          LOUP, SJOB, TRANAT
      INTEGER            I, IABS, INFO2, IRES, IWRK, IXBS, IXMA, J, JJ,
     $                   KASE, LDW, LWA, LWR, NN, SDIM, WRKOPT
      DOUBLE PRECISION   ANORM, BIGNUM, DENOM, EPS, EPSN, EPST, EST,
     $                   GNORM, PINORM, QNORM, SCALE, TEMP, THNORM,
     $                   TMAX, XANORM, XNORM
C     ..
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 )
      INTEGER            ISAVE( 3 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME, SELECT
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANHS, DLANSY
      EXTERNAL           DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT
C     ..
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEES, DGEMM, DGESV, DLACN2,
     $                   DLACPY, DLASET, DSCAL, DSWAP, DSYMM, MA02ED,
     $                   MB01RU, MB01RX, MB01RY, MB01UD, SB03MX, SB03SX,
     $                   SB03SY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      JOBC   = LSAME( JOB,    'C' )
      JOBE   = LSAME( JOB,    'E' )
      JOBB   = LSAME( JOB,    'B' )
      NOFACT = LSAME( FACT,   'N' )
      NOTRNA = LSAME( TRANA,  'N' )
      LOWER  = LSAME( UPLO,   'L' )
      UPDATE = LSAME( LYAPUN, 'O' )
C
      NEEDAC = UPDATE .AND. .NOT.JOBC
C
      NN = N*N
      IF( UPDATE ) THEN
         LWA = NN
      ELSE
         LWA = 0
      END IF
C
      IF( JOBC ) THEN
         LDW = MAX( 3, 2*NN ) + NN
      ELSE
         LDW = MAX( 3, 2*NN ) + 2*NN
         IF( .NOT.UPDATE )
     $      LDW = LDW + N
      END IF
      IF( NOFACT )
     $   LDW = MAX( LWA + 5*N, LDW )
C
      INFO = 0
      IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT,   'F' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA,  'T' ) .OR.
     $                            LSAME( TRANA,  'C' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( LOWER  .OR. LSAME( UPLO,   'U' ) ) ) THEN
         INFO = -4
      ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.1 .OR.
     $       ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN
         INFO = -8
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN
         INFO = -12
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF( NOFACT ) THEN
            IF( UPDATE ) THEN
               SJOB = 'V'
            ELSE
               SJOB = 'N'
            END IF
         END IF
         IF( LQUERY ) THEN
            IF( NOFACT ) THEN
               CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $                     DWORK, DWORK, U, LDU, DWORK, -1, BWORK,
     $                     INFO )
               WRKOPT = MAX( LDW, INT( DWORK( 1 ) ) + LWA + 2*N )
            ELSE
               WRKOPT = LDW
            END IF
         END IF
         IF( LDWORK.LT.LDW .AND. .NOT. LQUERY )
     $      INFO = -24
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB02SD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK( 1 ) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IF( .NOT.JOBE )
     $      RCOND = ONE
         IF( .NOT.JOBC )
     $      FERR  = ZERO
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Compute the 1-norm of the matrix X.
C
      XNORM = DLANSY( '1-norm', UPLO, N, X, LDX, DWORK )
      IF( XNORM.EQ.ZERO ) THEN
C
C        The solution is zero.
C
         IF( .NOT.JOBE )
     $      RCOND = ZERO
         IF( .NOT.JOBC )
     $      FERR  = ZERO
         DWORK( 1 ) = DBLE( N )
         RETURN
      END IF
C
C     Workspace usage.
C
      IRES = 0
      IXBS = IRES + NN
      IXMA = MAX( 3, 2*NN )
      IABS = IXMA + NN
      IWRK = IABS + NN
C
C     Workspace:  LWK, where
C                 LWK = 2*N*N, if LYAPUN = 'O', or FACT = 'N',
C                 LWK = N,     otherwise.
C
      IF( UPDATE .OR. NOFACT ) THEN
C
         CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK( IXBS+1 ), N )
         CALL DSYMM(  'Left', UPLO, N, N, ONE, G, LDG, X, LDX, ONE,
     $                DWORK( IXBS+1 ), N )
         IF( NOTRNA ) THEN
C                                   -1
C           Compute Ac = (I_n + G*X)  *A.
C
            CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N )
            CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N,
     $                  INFO2 )
         ELSE
C                                     -1
C           Compute Ac = A*(I_n + X*G)  .
C
            DO 10 J = 1, N
               CALL DCOPY( N, A( 1, J ), 1, DWORK( J ), N )
   10       CONTINUE
            CALL DGESV( N, N, DWORK( IXBS+1 ), N, IWORK, DWORK, N,
     $                  INFO2 )
            DO 20 J = 2, N
               CALL DSWAP( J-1, DWORK( (J-1)*N+1 ), 1, DWORK( J ), N )
   20       CONTINUE
         END IF
C
         WRKOPT = DBLE( 2*NN )
         IF( NOFACT )
     $      CALL DLACPY( 'Full', N, N, DWORK, N, T, LDT )
      ELSE
         WRKOPT = DBLE( N )
      END IF
C
      IF( NOFACT ) THEN
C
C        Compute the Schur factorization of Ac, Ac = U*T*U'.
C        Workspace:  need   LWA + 5*N;
C                    prefer larger;
C                    LWA = N*N, if LYAPUN = 'O';
C                    LWA = 0,   otherwise.
C        (Note: Comments in the code beginning "Workspace:" describe the
C        minimal amount of real workspace needed at that point in the
C        code, as well as the preferred amount for good performance.)
C
         CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM,
     $               DWORK( LWA+1 ), DWORK( LWA+N+1 ), U, LDU,
     $               DWORK( LWA+2*N+1 ), LDWORK-LWA-2*N, BWORK, INFO )
         IF( INFO.GT.0 ) THEN
            IF( LWA.GT.0 )
     $         CALL DCOPY( 2*N, DWORK( LWA+1 ), 1, DWORK, 1 )
            RETURN
         END IF
C
         WRKOPT = MAX( WRKOPT, INT( DWORK( LWA+2*N+1 ) ) + LWA + 2*N )
      END IF
      IF( NEEDAC ) THEN
         CALL DLACPY( 'Full', N, N, DWORK, N, DWORK( IABS+1 ), N )
         LWR = NN
      ELSE
         LWR = 0
      END IF
C
      IF( NOTRNA ) THEN
         TRANAT = 'T'
      ELSE
         TRANAT = 'N'
      END IF
C                         _
C     Compute X*op(Ac) or X*op(T).
C
      IF( UPDATE ) THEN
         CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, DWORK,
     $               N, ZERO, DWORK( IXMA+1 ), N )
      ELSE
         CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX,
     $                DWORK( IXMA+1 ), N, INFO2 )
      END IF
C
      IF( .NOT.JOBE ) THEN
C
C        Estimate sepd(op(Ac),op(Ac)') = sepd(op(T),op(T)') and
C        norm(Theta).
C        Workspace LWR + MAX(3,2*N*N) + N*N, where
C                  LWR = N*N, if LYAPUN = 'O' and JOB = 'B',
C                  LWR = 0,   otherwise.
C
         CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU,
     $                DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK,
     $                IXMA, INFO )
C
         WRKOPT = MAX( WRKOPT, LWR + MAX( 3, 2*NN ) + NN )
C
C        Return if the equation is singular.
C
         IF( SEPD.EQ.ZERO ) THEN
            RCOND = ZERO
            IF( JOBB )
     $         FERR = ONE
            DWORK( 1 ) = DBLE( WRKOPT )
            RETURN
         END IF
C
C        Estimate norm(Pi).
C        Workspace LWR + MAX(3,2*N*N) + N*N.
C
         KASE = 0
C
C        REPEAT
   30    CONTINUE
         CALL DLACN2( NN, DWORK( IXBS+1 ), DWORK, IWORK, EST, KASE,
     $                ISAVE )
         IF( KASE.NE.0 ) THEN
C
C           Select the triangular part of symmetric matrix to be used.
C
            IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( IXBS+1 ))
     $          .GE.
     $          DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( IXBS+1 ))
     $        ) THEN
               LOUP = 'U'
            ELSE
               LOUP = 'L'
            END IF
C                                                        _   _
C           Compute RHS = op(Ac)'*X*W*X*op(Ac) or op(T)'*X*W*X*op(T).
C
            CALL MB01RU( LOUP, TRANAT, N, N, ZERO, ONE, DWORK, N,
     $                   DWORK( IXMA+1 ), N, DWORK, N, DWORK( IXBS+1 ),
     $                   NN, INFO2 )
            CALL DSCAL( N, HALF, DWORK, N+1 )
C
            IF( UPDATE ) THEN
C
C              Transform the right-hand side: RHS := U'*RHS*U.
C
               CALL MB01RU( LOUP, 'Transpose', N, N, ZERO, ONE, DWORK,
     $                      N, U, LDU, DWORK, N, DWORK( IXBS+1 ), NN,
     $                      INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
            END IF
C
C           Fill in the remaining triangle of the symmetric matrix.
C
            CALL MA02ED( LOUP, N, DWORK, N )
C
            IF( KASE.EQ.1 ) THEN
C
C              Solve op(T)'*Y*op(T) - Y = scale*RHS.
C
               CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE,
     $                      DWORK( IXBS+1 ), INFO2 )
            ELSE
C
C              Solve op(T)*W*op(T)' - W = scale*RHS.
C
               CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE,
     $                      DWORK( IXBS+1 ), INFO2 )
            END IF
C
            IF( UPDATE ) THEN
C
C              Transform back to obtain the solution: Z := U*Z*U', with
C              Z = Y or Z = W.
C
               CALL MB01RU( LOUP, 'No transpose', N, N, ZERO, ONE,
     $                      DWORK, N, U, LDU, DWORK, N, DWORK( IXBS+1 ),
     $                      NN, INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
C
C              Fill in the remaining triangle of the symmetric matrix.
C
               CALL MA02ED( LOUP, N, DWORK, N )
            END IF
            GO TO 30
         END IF
C        UNTIL KASE = 0
C
         IF( EST.LT.SCALE ) THEN
            PINORM = EST / SCALE
         ELSE
            BIGNUM = ONE / DLAMCH( 'Safe minimum' )
            IF( EST.LT.SCALE*BIGNUM ) THEN
               PINORM = EST / SCALE
            ELSE
               PINORM = BIGNUM
            END IF
         END IF
C
C        Compute the 1-norm of A or T.
C
         IF( UPDATE ) THEN
            ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
         ELSE
            ANORM = DLANHS( '1-norm', N, T, LDT, DWORK )
         END IF
C
C        Compute the 1-norms of the matrices Q and G.
C
         QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK )
         GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK )
C
C        Estimate the reciprocal condition number.
C
         TMAX = MAX( SEPD, XNORM, ANORM, GNORM )
         IF( TMAX.LE.ONE ) THEN
            TEMP  = SEPD*XNORM
            DENOM = QNORM + ( SEPD*ANORM )*THNORM +
     $                      ( SEPD*GNORM )*PINORM
         ELSE
            TEMP  =   ( SEPD / TMAX )*( XNORM / TMAX )
            DENOM = ( ( ONE  / TMAX )*( QNORM / TMAX ) ) +
     $              ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM +
     $              ( ( SEPD / TMAX )*( GNORM / TMAX ) )*PINORM
         END IF
         IF( TEMP.GE.DENOM ) THEN
            RCOND = ONE
         ELSE
            RCOND = TEMP / DENOM
         END IF
      END IF
C
      IF( .NOT.JOBC ) THEN
C
C        Form a triangle of the residual matrix
C          R = op(Ac)'*X*op(Ac) + op(Ac)'*X*G*X*op(Ac) + Q - X,
C        or           _                _ _ _         _   _
C          R = op(T)'*X*op(T) + op(T)'*X*G*X*op(T) + Q - X,
C        exploiting the symmetry. Actually, the equivalent formula
C          R = op(A)'*X*op(Ac) + Q - X
C        is used in the first case.
C        Workspace MAX(3,2*N*N) + 2*N*N,     if LYAPUN = 'O';
C                  MAX(3,2*N*N) + 2*N*N + N, if LYAPUN = 'R'.
C
         CALL DLACPY( UPLO, N, N, Q, LDQ, DWORK( IRES+1 ), N )
         JJ = IRES + 1
         IF( LOWER ) THEN
            DO 40 J = 1, N
               CALL DAXPY( N-J+1, -ONE, X( J, J ), 1, DWORK( JJ ), 1 )
               JJ = JJ + N + 1
   40       CONTINUE
         ELSE
            DO 50 J = 1, N
               CALL DAXPY( J, -ONE, X( 1, J ), 1, DWORK( JJ ), 1 )
               JJ = JJ + N
   50       CONTINUE
         END IF
C
         IF( UPDATE ) THEN
            CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, ONE,
     $                   DWORK( IRES+1 ), N, A, LDA, DWORK( IXMA+1 ), N,
     $                   INFO2 )
         ELSE
            CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, ONE,
     $                   DWORK( IRES+1 ), N, T, LDT, DWORK( IXMA+1 ), N,
     $                   DWORK( IWRK+1 ), INFO2 )
            CALL DSYMM(  'Left', UPLO, N, N, ONE, G, LDG,
     $                   DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N )
            CALL MB01RX( 'Left', UPLO, 'Transpose', N, N, ONE, ONE,
     $                   DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N,
     $                   DWORK( IXBS+1 ), N, INFO2 )
         END IF
C
C        Get the machine precision.
C
         EPS  = DLAMCH( 'Epsilon' )
         EPSN = EPS*DBLE( N + 4 )
         EPST = EPS*DBLE( 2*( N + 1 ) )
         TEMP = EPS*FOUR
C
C        Add to abs(R) a term that takes account of rounding errors in
C        forming R:
C         abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) +
C                   (n+4)*abs(op(Ac))'*abs(X)*abs(op(Ac)) + 2*(n+1)*
C                   abs(op(Ac))'*abs(X)*abs(G)*abs(X)*abs(op(Ac))),
C        or                             _          _
C         abs(R) := abs(R) + EPS*(4*abs(Q) + 4*abs(X) +
C                                         _
C                   (n+4)*abs(op(T))'*abs(X)*abs(op(T)) +
C                                         _      _      _
C                 2*(n+1)*abs(op(T))'*abs(X)*abs(G)*abs(X)*abs(op(T))),
C        where EPS is the machine precision.
C
         DO 70 J = 1, N
            DO 60 I = 1, N
               DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) )
   60       CONTINUE
   70    CONTINUE
C
         IF( LOWER ) THEN
            DO 90 J = 1, N
               DO 80 I = J, N
                  DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) +
     $                                             ABS( X( I, J ) ) ) +
     $                                 ABS( DWORK( IRES+(J-1)*N+I ) )
   80          CONTINUE
   90       CONTINUE
         ELSE
            DO 110 J = 1, N
               DO 100 I = 1, J
                  DWORK( IRES+(J-1)*N+I ) = TEMP*( ABS( Q( I, J ) ) +
     $                                             ABS( X( I, J ) ) ) +
     $                                 ABS( DWORK( IRES+(J-1)*N+I ) )
  100          CONTINUE
  110       CONTINUE
         END IF
C
         IF( UPDATE ) THEN
C
            DO 130 J = 1, N
               DO 120 I = 1, N
                  DWORK( IABS+(J-1)*N+I ) =
     $               ABS( DWORK( IABS+(J-1)*N+I ) )
  120          CONTINUE
  130       CONTINUE
C
            CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE,
     $                  DWORK( IXBS+1 ), N, DWORK( IABS+1 ), N, ZERO,
     $                  DWORK( IXMA+1 ), N )
            CALL MB01RX( 'Left', UPLO, TRANAT, N, N, ONE, EPSN,
     $                   DWORK( IRES+1 ), N, DWORK( IABS+1 ), N,
     $                   DWORK( IXMA+1 ), N, INFO2 )
         ELSE
C
            DO 150 J = 1, N
               DO 140 I = 1, MIN( J+1, N )
                  DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) )
  140          CONTINUE
  150       CONTINUE
C
            CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N,
     $                   DWORK( IXBS+1 ), N, DWORK( IXMA+1 ), N, INFO2 )
            CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN,
     $                   DWORK( IRES+1 ), N, DWORK( IABS+1 ), N,
     $                   DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), INFO2 )
         END IF
C
         IF( LOWER ) THEN
            DO 170 J = 1, N
               DO 160 I = J, N
                  DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) )
  160          CONTINUE
  170       CONTINUE
         ELSE
            DO 190 J = 1, N
               DO 180 I = 1, J
                  DWORK( IABS+(J-1)*N+I ) = ABS( G( I, J ) )
  180          CONTINUE
  190       CONTINUE
         END IF
C
         IF( UPDATE ) THEN
            CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPST, DWORK( IRES+1 ),
     $                   N, DWORK( IXMA+1 ), N, DWORK( IABS+1 ), N,
     $                   DWORK( IXBS+1 ), NN, INFO2 )
            WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN )
         ELSE
            CALL DSYMM(  'Left', UPLO, N, N, ONE,  DWORK( IABS+1 ), N,
     $                   DWORK( IXMA+1 ), N, ZERO, DWORK( IXBS+1 ), N )
            CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPST,
     $                   DWORK( IRES+1 ), N, DWORK( IXMA+1 ), N,
     $                   DWORK( IXBS+1 ), N, DWORK( IWRK+1 ), INFO2 )
            WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + 2*NN + N )
         END IF
C
C        Compute forward error bound, using matrix norm estimator.
C        Workspace MAX(3,2*N*N) + N*N.
C
         XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK )
C
         CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
     $                DWORK( IRES+1 ), N, FERR, IWORK, DWORK( IXBS+1 ),
     $                IXMA, INFO )
      END IF
C
      DWORK( 1 ) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of SB02SD ***
      END


subroutine CalcEnergy(Pos, L, rc, PEnergy, Dim, NAtom)
    implicit none
    integer, intent(in) :: Dim, NAtom
    real(8), intent(in), dimension(0:NAtom-1, 0:Dim-1) :: Pos
    real(8), intent(in) :: L, rc
    real(8), intent(out) :: PEnergy
    real(8), parameter :: k = 3000., r0 = 1.
    integer:: i, j
    real(8) :: d2, sep, disp, shiftval, rc2, id6, id2, id12
    real(8), dimension(Dim) :: rij, Posi

    !Assign initially zeros to the force array and potential energy
    PEnergy = 0.
    rc2 = rc**2

    !Precompute constants such as LJ shift value up here
    id6 = 1./rc**6
    shiftval = 4*(id6**2 - id6)

    do i=0, NAtom - 1
        !store Pos(i,:) in a temporary array for faster access in j looop
        Posi = Pos(i,:)
        do j = i+1, NAtom - 1
            !compute initial rij
            rij = Pos(j,:) - Posi
            !Apply minimum image convention
            rij = rij - L*dnint(rij / L)

            !compute scalar distance
            d2 = sum(rij*rij)
            !Check against cutoff
            if ( d2 > rc2) then
                cycle
            end if
            id2 = 1./d2                 !inverse squared distance
            id6 = id2 * id2 * id2       !inverse sixth distance
            id12 = id6 * id6            !inverse twelfth distance
            PEnergy = Penergy + 4. * (id12 - id6) + shiftval

        enddo
    enddo
end subroutine


    Program dorghr_example

!     DORGHR Example Program Text

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

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgehrd, dhseqr, dlange, dorghr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: alpha, beta, norm
      Integer :: i, ifail, info, lda, ldc, ldd, ldz, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), d(:, :), tau(:), wi(:), &
        work(:), wr(:), z(:, :)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon
!     .. Executable Statements ..
      Write (nout, *) 'DORGHR Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldz = n
      ldc = n
      ldd = n
      lwork = 64*(n-1)
      Allocate (a(lda,n), c(ldc,n), d(ldd,n), tau(n), wi(n), work(lwork), &
        wr(n), z(ldz,n))

!     Read A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     Copy A into D.
      d(1:n, 1:n) = a(1:n, 1:n)

      Write (nout, *)
      Flush (nout)

!     Print Matrix A
!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A', ifail)

      Write (nout, *)
      Flush (nout)

!     Reduce A to upper Hessenberg form H = (Q**T)*A*Q
      Call dgehrd(n, 1, n, a, lda, tau, work, lwork, info)

!     Copy A into Z
      z(1:n, 1:n) = a(1:n, 1:n)

!     Form Q explicitly, storing the result in Z
      Call dorghr(n, 1, n, z, ldz, tau, work, lwork, info)

!     Calculate the Schur factorization of H = Y*T*(Y**T) and form
!     Q*Y explicitly, storing the result in Z

!     Note that A = Z*T*(Z**T), where Z = Q*Y
      Call dhseqr('Schur form', 'Vectors', n, 1, n, a, lda, wr, wi, z, ldz, &
        work, lwork, info)

!     Compute A - Z*T*Z^T from the factorization of A and store in matrix D.
      alpha = 1.0_dp
      beta = 0.0_dp
      Call dgemm('N', 'N', n, n, n, alpha, z, ldz, a, lda, beta, c, ldc)
      alpha = -1.0_dp
      beta = 1.0_dp
      Call dgemm('N', 'T', n, n, n, alpha, c, ldc, z, ldz, beta, d, ldd)

!     Find norm of difference matrix D and warn if it is too large;
      norm = dlange('O', ldd, n, d, ldd, work)
      If (norm>epsilon(1.0E0_dp)**0.8_dp) Then
        Write (nout, *) 'Norm of A-(Z*T*Z^T) is much greater than 0.'
        Write (nout, *) 'Schur factorization has failed.'
      Else
!       Print eigenvalues.
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100)(' (', wr(i), ',', wi(i), ')', i=1, n)
      End If

100   Format (1X, A, F8.4, A, F8.4, A)

    End Program


!----------------------------------------------------------------------
! NEMO system team, System and Interface for oceanic RElocable Nesting
!----------------------------------------------------------------------
!
! DESCRIPTION:
!> @brief This module defines physical constant.
!>
!> @author
!> J.paul
! REVISION HISTORY:
!> @date November, 2013 - Initial Version
!> @date September, 2015
!> - add physical constant to compute meshmask
!> @date January, 2019
!> - half reduce epsilon value
!>
!> @note Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
!----------------------------------------------------------------------
MODULE phycst

   USE kind                         ! F90 kind parameter

   IMPLICIT NONE
   ! NOTE_avoid_public_variables_if_possible

   PUBLIC :: dp_pi      !< pi
   PUBLIC :: dp_eps     !< epsilon value
   PUBLIC :: dp_rearth  !< earth radius [m]
   PUBLIC :: dp_deg2rad !< degree to radian ratio
   PUBLIC :: dp_rad2deg !< radian to degree ratio
   PUBLIC :: dp_delta   !<
   PUBLIC :: dp_omega   !< earth rotation parameter [s-1]
   PUBLIC :: dp_day     !< day                                [s]
   PUBLIC :: dp_siyea   !< sideral year                       [s]
   PUBLIC :: dp_siday   !< sideral day                        [s]

   REAL(dp), PUBLIC ::   rday = 24.*60.*60.     !: day                                [s]
   REAL(dp), PUBLIC ::   rsiyea                 !: sideral year                       [s]
   REAL(dp), PUBLIC ::   rsiday                 !: sideral day                        [s]

   REAL(dp), PARAMETER :: dp_pi = 3.14159274101257_dp
   REAL(dp), PARAMETER :: dp_eps = 0.5 * EPSILON(1._dp)
   REAL(dp), PARAMETER :: dp_rearth = 6371229._dp !m
   REAL(dp), PARAMETER :: dp_deg2rad = dp_pi/180.0
   REAL(dp), PARAMETER :: dp_rad2deg = 180.0/dp_pi

   REAL(dp), PARAMETER :: dp_day = 24.*60.*60.
   REAL(dp), PARAMETER :: dp_siyea = 365.25_dp * dp_day * &
      &  2._dp * dp_pi / 6.283076_dp
   REAL(dp), PARAMETER :: dp_siday = dp_day / ( 1._dp + dp_day / dp_siyea )

   REAL(dp), PARAMETER :: dp_delta=1.e-6
   REAL(dp), PARAMETER :: dp_omega= 2._dp * dp_pi / dp_siday

END MODULE phycst


        subroutine GETPHIPOINT(
     &           phi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 phi
      REAL*8 freq(0:0)
      REAL*8 x(0:0)
        phi = sin(freq(0)*x(0))
        return
        end
        subroutine GETLOFPHI(
     &           lofphi
     &           ,ilofphilo0
     &           ,ilofphihi0
     &           ,freq
     &           ,dx
     &           ,problo
     &           ,probhi
     &           ,aCoef
     &           ,bCoef
     &           ,iboxlo0
     &           ,iboxhi0
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      integer ilofphilo0
      integer ilofphihi0
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0)
      REAL*8 freq(0:0)
      REAL*8 dx(0:0)
      REAL*8 problo(0:0)
      REAL*8 probhi(0:0)
      REAL*8 aCoef
      REAL*8 bCoef
      integer iboxlo0
      integer iboxhi0
        integer i
        REAL*8 x(0:1 -1)
      do i = iboxlo0,iboxhi0
          x(0) = (i+(0.500d0))*dx(0) + problo(0)
          call getlofphipoint(lofphi(i),freq,x,aCoef,bCoef)
      enddo
        return
        end
        subroutine GETLOFPHIPOINT(
     &           lofphi
     &           ,freq
     &           ,x
     &           ,aCoefmult
     &           ,bCoefmult
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 lofphi
      REAL*8 freq(0:0)
      REAL*8 x(0:0)
      REAL*8 aCoefmult
      REAL*8 bCoefmult
        integer dir
        REAL*8 fac,phi, temp
        fac = -(freq(0)**2)
        fac = fac *(x(0))
        phi = (sin(freq(0)*x(0)))
        lofphi = fac*phi
        temp = 0.0
        do dir=0, 1 -1
           if (dir.eq.0) then
              temp = freq(0)*cos(freq(0)*x(0))
           endif
           lofphi = lofphi + temp
        enddo
        lofphi = aCoefmult*x(0)*phi + bCoefmult*lofphi
        return
        end
        subroutine GETGRADPHIPOINT(
     &           gradphi
     &           ,freq
     &           ,x
     &           )
      implicit none
      integer*8 ch_flops
      COMMON/ch_timer/ ch_flops
      REAL*8 gradphi(0:0)
      REAL*8 freq(0:0)
      REAL*8 x(0:0)
        gradphi(0) = freq(0) * cos(freq(0)*x(0))
        return
        end


program uranium
! Calculates Thomas-Fermi nonrelativistic energies for Z=92 (U)
!
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 1e6_dp
integer, parameter :: NN = 3000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-6_dp
integer :: converged, n, l, Z_eff
real(dp) :: R(NN+1), V(size(r)), E, P(size(r)), Q(size(r)), E_initial
real(dp) :: Rp(NN+1)

integer, parameter :: relat = 0

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
V = thomas_fermi_potential(R, Z)

print *, "Thomas Fermi nonrelativistic energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_initial"
print *
do n = 1, 7
    do l = 0, n-1
        Z_eff = Z - 2*((n-1)**2 + 2*l+1)
        if (Z_eff <= 0) Z_eff = 1
        E_initial = -Z_eff**2 * 1.0_dp/(2*n**2)
        call solve_radial_eigenproblem(n, l, E_initial, eps, 100, R, Rp, &
            V, Z, c, relat, .true., -10000._dp, 0._dp, converged, E, P, Q)
        print "(I3, I3, F15.6, F15.6)", n, l, E, E_initial
    end do
end do
end program


program gauss_jordan
  use gauss
  use mats
  implicit none
  real, allocatable :: mat(:, :)
  integer :: n, m

  print *, 'Enter matrix dimensions (columns, rows):'
  read (*, *) n, m
  allocate(mat(n, m))

  print *, 'Enter matrix values:'
  read (*, *) mat

  print *, 'Reduced matrix:'
  call reduce(mat)
  call print_mat(mat)
end program gauss_jordan


program test2

    ! Sample solution for Homework 4.

    use quadrature, only: trapezoid, error_table

    implicit none
    real(kind=8) :: a,b,int_true,k
    integer :: nvals(12)
    integer :: i

    k = 1.d3
    a = 0.d0
    b = 2.d0
    int_true = (b-a) + (b**4 - a**4) / 4.d0 - (1.d0/k) * (cos(k*b) - cos(k*a))

    print 10, int_true
 10 format("true integral: ", es22.14)
    print *, " "  ! blank line

    ! values of n to test:
    do i=1,12
        nvals(i) = 5 * 2**(i-1)
        enddo

    call error_table(f, a, b, nvals, int_true)

contains

    real(kind=8) function f(x)
        implicit none
        real(kind=8), intent(in) :: x

        f = 1.d0 + x**3 + sin(k*x)
    end function f

end program test2


      PROGRAM xfgauss
C     driver for routine fgauss
      INTEGER NA,NLIN,NPT
      PARAMETER(NPT=3,NLIN=2,NA=3*NLIN)
      INTEGER i,j
      REAL e1,e2,f,x,y,a(NA),dyda(NA),df(NA)
      DATA a/3.0,0.2,0.5,1.0,0.7,0.3/
      write(*,'(/1x,t6,a,t14,a,t19,a,t27,a,t35,a,t43,a,t51,a,t59,a)')
     *     'X','Y','DYDA1','DYDA2','DYDA3','DYDA4','DYDA5','DYDA6'
      do 11 i=1,NPT
        x=0.3*i
        call fgauss(x,a,y,dyda,NA)
        e1=exp(-((x-a(2))/a(3))**2)
        e2=exp(-((x-a(5))/a(6))**2)
        f=a(1)*e1+a(4)*e2
        df(1)=e1
        df(4)=e2
        df(2)=a(1)*e1*2.0*(x-a(2))/(a(3)**2)
        df(5)=a(4)*e2*2.0*(x-a(5))/(a(6)**2)
        df(3)=a(1)*e1*2.0*((x-a(2))**2)/(a(3)**3)
        df(6)=a(4)*e2*2.0*((x-a(5))**2)/(a(6)**3)
        write(*,'(1x,a/,8f8.4)') 'from FGAUSS',x,y,(dyda(j),j=1,6)
        write(*,'(1x,a/,8f8.4/)') 'independent calc.',x,f,(df(j),j=1,6)
11    continue
      END

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