!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_STEVX computes selected eigenvalues and, optionally, the
! corresponding eigenvectors of a real symmetric tridiagonal matrix A.
! Eigenvalues and eigenvectors can be selected by specifying either a
! range of values or a range of indices for the desired eigenvalues.
!
! =========
!
!        SUBROUTINE LA_STEVX( D, E, W, Z=z, VL=vl, VU=vu, &
!                         IL=il, IU=iu, M=m, IFAIL=ifail, &
!                         ABSTOL=abstol, INFO=info )
!             REAL(<wp>), INTENT(INOUT) :: D(:), E(:)
!             REAL(<wp>), INTENT(OUT) :: W(:)
!             REAL(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!             REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!             INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!             INTEGER, INTENT(OUT), OPTIONAL :: M
!             INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
!             REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!             INTEGER, INTENT(OUT), OPTIONAL :: INFO
!        where
!              <wp> ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! D        (input/output) REAL array, shape (:) with size(D) = n, where n
!          is the order of A.
!          On entry, the diagonal elements of the matrix A.
!          On exit, the original contents of D possibly multiplied by a
!          constant factor to avoid over/underflow in computing the
! 	   eigenvalues.
! E        (input/output) REAL array, shape (:) with size(E) = n.
!          On entry, the n-1 subdiagonal elements of A in E(1) to E(n-1).
! 	   E(n) need not be set.
!          On exit, the original contents of E possibly multiplied by a
! 	   constant factor to avoid over/underflow in computing the
! 	   eigenvalues.
! W        (output) REAL array with size(W) = n.
!          The first M elements contain the selected eigenvalues in
! 	   ascending order.
! Z        Optional (output) REAL or COMPLEX array, shape (:,:) with
!          size(Z,1) = n and size(Z,2) = M.
!          The first M columns of Z contain the orthonormal eigenvectors
! 	   of A corresponding to the selected eigenvalues, with the i-th
! 	   column of Z containing the eigenvector associated with the
!          eigenvalue in W(i) . If an eigenvector fails to converge, then
!          that column of Z contains the latest approximation to the
!          eigenvector, and the index of the eigenvector is returned in
! 	   IFAIL.
!          Note: The user must ensure that at least M columns are
! 	   supplied in the array Z. When the exact value of M is not
! 	   known in advance, an upper bound must be used. In all cases
! 	   M <= n.
! VL,VU    Optional (input) REAL.
!          The lower and upper bounds of the interval to be searched for
! 	   eigenvalues. VL < VU.
!          Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
! 	   <wp> ::= KIND(1.0) | KIND(1.0D0).
!          Note: Neither VL nor VU may be present if IL and/or IU is
! 	   present.
! IL,IU    Optional (input) INTEGER.
!          The indices of the smallest and largest eigenvalues to be
! 	   returned. The IL-th through IU-th eigenvalues will be found.
! 	   1 <= IL <= IU <= n.
!          Default values: IL = 1 and IU = n.
!          Note: Neither IL nor IU may be present if VL and/or VU is
! 	   present.
!          Note: All eigenvalues are calculated if none of the arguments
! 	   VL, VU, IL and IU are present.
! M        Optional (output) INTEGER.
!          The total number of eigenvalues found. 0 <= M <= n.
!          Note: If IL and IU are present then M = IU - IL + 1.
! IFAIL    Optional (output) INTEGER array, shape (:) with
!          size(IFAIL) = n.
!          If INFO = 0, the first M elements of IFAIL are zero.
!          If INFO > 0, then IFAIL contains the indices of the
! 	   eigenvectors that failed to converge.
!          Note: If Z is present then IFAIL should also be present.
! ABSTOL   Optional (input) REAL.
!          The absolute error tolerance for the eigenvalues. An
!          approximate eigenvalue is accepted as converged when it is
!          determined to lie in an interval [a,b] of width less than or
!          equal to ABSTOL + EPSILON(1.0_<wp>) * max(|a|,|b|),
!          where <wp> is the working precision. If ABSTOL <= 0, then
! 	   EPSILON(1.0_<wp>) * ||A||1 will be used in its place.
! 	   Eigenvalues will be computed most accurately when ABSTOL is
! 	   set to twice the underflow threshold
! 	   2 * LA_LAMCH(1.0_<wp>, 'Safe minimum'), not zero.
!          Default value: 0.0_<wp>.
!          Note: If this routine returns with INFO > 0, then some
! 	   eigenvectors did not converge. Try setting ABSTOL to
! 	   2 * LA_LAMCH(1.0_<wp>, 'Safe minimum').
! INFO     Optional (output) INTEGER
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, then i eigenvectors failed to converge.
! 	      Their indices are stored in array IFAIL.
!          If INFO is not present and an error occurs, then the program
! 	   is terminated with an error message.
!----------------------------------------------------------------------
SUBROUTINE DSTEVX_F95( D, E, W, Z, VL, VU, IL, IU, M, &
                            IFAIL, ABSTOL, INFO )
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO
   USE F77_LAPACK, ONLY: STEVX_F77 => LA_STEVX, LAMCH_F77 => DLAMCH
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(IN), OPTIONAL :: IL, IU
   INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
   REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
   REAL(WP), INTENT(INOUT) :: D(:), E(:)
   REAL(WP), INTENT(OUT) :: W(:)
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_STEVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBZ, LRANGE
   INTEGER :: N, LD, LIL, LIU, LM, SIFAIL, S1Z, S2Z
   INTEGER :: LINFO, ISTAT
   INTEGER, TARGET :: ISTAT1(1)
   REAL(WP), TARGET :: LLZ(1,1)
   REAL(WP) :: LABSTOL, LVL, LVU
!  .. LOCAL ARRAYS ..
   INTEGER, POINTER :: IWORK(:), LIFAIL(:)
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(D); LD = MAX(1,N)
   IF( PRESENT(M)) M = 0
   IF( PRESENT(IFAIL) )THEN; SIFAIL = SIZE(IFAIL); ELSE; SIFAIL = N; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN; LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
   IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2)
   ELSE; S1Z = 1; S2Z = 1; ENDIF
!  .. TEST THE ARGUMENTS
   IF( N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE( E ) /= N .AND. N > 0 )THEN; LINFO = -2
   ELSE IF( SIZE( W ) /= N )THEN; LINFO = -3
   ELSE IF( PRESENT(Z) .AND. ( S1Z /= LD .OR. S2Z /= N ) )THEN; LINFO = -4
   ELSE IF( LVU < LVL )THEN; LINFO = -5
   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
     &         (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -6
   ELSE IF(( LIU < LIL .OR. LIL < 1) .AND. N>0 )THEN; LINFO = -7
   ELSE IF( N < LIU )THEN; LINFO = -8
   ELSE IF( SIFAIL /= N .OR. PRESENT(IFAIL).AND..NOT.PRESENT(Z) )THEN; LINFO = -10
   ELSE IF( N > 0 )THEN
      IF( PRESENT(VL) .OR. PRESENT(VU) )THEN; LRANGE = 'V'; LM = N
      ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN; LRANGE = 'I'; LM = LIU-LIL+1
      ELSE; LRANGE = 'A'; LM = N; END IF
      IF( PRESENT(Z) ) THEN; LJOBZ = 'V'
         IF( PRESENT(IFAIL) )THEN; LIFAIL => IFAIL
         ELSE; ALLOCATE( LIFAIL(N), STAT=ISTAT ); END IF
      ELSE; LJOBZ = 'N'
      LIFAIL => ISTAT1; ENDIF
!     .. DETERMINE THE WORKSPACE
      IF( ISTAT == 0 ) THEN
         ALLOCATE(IWORK(5*N), WORK(5*N), STAT=ISTAT)
         IF( ISTAT == 0 )THEN
            IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
            ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum'); ENDIF
	    IF (PRESENT(Z)) THEN
               CALL STEVX_F77( LJOBZ, LRANGE, N, D, E, LVL, LVU, LIL, LIU, &
                            LABSTOL, LM, W, Z, S1Z, WORK, IWORK, LIFAIL, LINFO )
	    ELSE
	       CALL STEVX_F77( LJOBZ, LRANGE, N, D, E, LVL, LVU, LIL, LIU, &
                            LABSTOL, LM, W, LLZ, S1Z, WORK, IWORK, LIFAIL, LINFO )
	    ENDIF
            IF( PRESENT(M) ) M = LM
            W(LM+1:N) = 0.0_WP
         ELSE; LINFO = -100; END IF
      END IF
      IF( PRESENT(Z) .AND. .NOT.PRESENT(IFAIL) ) DEALLOCATE( LIFAIL, STAT=ISTAT1(1) )
      DEALLOCATE(IWORK, WORK, STAT=ISTAT1(1))
   END IF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DSTEVX_F95


! This file now contains TOMS algorithm 668 as a separate module.
! Latest revision - 24 July 2000
! amiller@bigpond.net.au
! http://users.bigpond.net.au/amiller/

MODULE random_hypergeometric
! Generate random deviates from the hypergeometric distribution.
! The notation used for the 2 x 2 table is:

!   x  r-x |  r
!          |
!  g-x     | N-r
! _________|_____
!          |
!   g  N-g |  N

! where N, r, g are fixed, and x is the random value to be generated.

! Two methods are included.

! r_hyperg is a simple method which is suitable when MIN(r,g) is small,
!          say <= 10.

! h_alias is much faster for larger values of MIN(r,g) but requires a table
!         of hypergeometric probabilities to be set up on the first call.
!         It is not suitable if the marginal totals (N, r, g) change.

! Latest revision - 24 July 2000

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

REAL (dp), ALLOCATABLE, SAVE  :: p(:), f(:)
INTEGER, ALLOCATABLE, SAVE    :: l(:)
INTEGER, SAVE                 :: Nlast = 0, rlast = 0, glast = 0, xmax

CONTAINS

FUNCTION r_hyperg(N, r, g) RESULT(x)

! This is algorithm 3.1 from page 52 of:
!   Dagpunar, John (1988) `Principles of Random Variate Generation'
!   published by Clarendon Press, Oxford.   ISBN 0-19-852202-9

INTEGER, INTENT(IN)  :: N, r, g
INTEGER              :: x

! Local variables

INTEGER  :: gg, i, NN
REAL     :: p, u

gg = g
NN = N
i = 1
x = 0
DO
  IF (gg <= 0 .OR. i > r) EXIT
  p = REAL(gg) / NN
  CALL RANDOM_NUMBER(u)
  IF (u < p) THEN
    x = x + 1
    gg = gg - 1
  END IF
  i = i + 1
  NN = NN - 1
END DO

RETURN
END FUNCTION r_hyperg

FUNCTION h_alias(N, r, g) RESULT(x)

! This is algorithm HALIAS from:

! Kachitvichyanukul, V. & Schmeiser, B. (1985)
! `Computer Generation of Hypergeometric Random Variates',
! J. of Statistical Computation & Simulation, vol.22, 127-145.

INTEGER, INTENT(IN)  :: N, r, g
INTEGER              :: x

! Local variables
INTEGER    :: i, i0, nn(2,2)
REAL (dp)  :: u, p_last

! If this is the first call, or N, r or g has changed, call alias
! to set up new tables.

IF (N /= Nlast .OR. r /= rlast .OR. g /= glast) THEN
  Nlast = N
  rlast = r
  glast = g
  xmax = MIN(r,g)
  IF (ALLOCATED( p )) DEALLOCATE( p, f, l )
  ALLOCATE( p(0:xmax), f(0:xmax), l(0:xmax) )

! Calculate the set of hypergeometric probabilities
! First calculate the maximum probability which occurs near
! i = (r+1)(g+1)/(N+2)

  i0 = NINT( REAL((r+1)*(g+1)) / REAL(N+2) )
  i0 = MIN(i0, xmax)
  nn(1,1) = i0
  nn(1,2) = r - i0
  nn(2,1) = g - i0
  nn(2,2) = N - r - g + i0
  p(i0) = hyperg(nn)

  p_last = p(i0)
  DO i = i0-1, 0, -1
    p(i) = p_last * REAL( (i+1)*(N-r-g+i+1), KIND=dp ) /  &
                    REAL( (r-i)*(g-i), KIND=dp )
    p_last = p(i)
  END DO

  p_last = p(i0)
  DO i = i0+1, xmax
    p(i) = p_last * REAL( (r-i+1)*(g-i+1), KIND=dp ) /  &
                    REAL( i*(N-r-g+i), KIND=dp )
    p_last = p(i)
  END DO

! Call ALIAS to set up its tables of F and L.

  CALL alias(p, xmax+1, f, l)
END IF

! Generate an integer in the range 0 to XMAX
CALL RANDOM_NUMBER(u)
x = u * (xmax + 1)

! Accept it if it is <= f(x), otherwise use its alias.
CALL RANDOM_NUMBER(u)
IF (u > f(x)) x = l(x) - 1

RETURN
END FUNCTION h_alias

FUNCTION hyperg(n) RESULT(prob)

!  Calculate hypergeometric probability for a 2 x 2 table:
!      n(1,1)  n(1,2)
!      n(2,1)  n(2,2)

!  For large numbers, it would be faster to use Stirling's
!  approximation or similar for the factorials.

!  Programmer: Alan Miller
!  Latest revision - 9 January 1997

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(2,2)
REAL (dp)            :: prob

!     Local variables

INTEGER    :: ncell(1:4), ntot(1:4), nall
LOGICAL    :: ended
REAL (dp)  :: zero = 0.0_dp, one = 1.0_dp

!     Check that all elements are positive or zero.

IF (n(1,1) < 0 .OR. n(1,2) < 0 .OR. n(2,1) < 0 .OR. n(2,2) < 0) THEN
  WRITE(*, *) '** Negative cell frequency in argument to HYPERG **'
  prob = zero
  RETURN
END IF

!     Copy the cell frequencies into ncell and order them.
!     Calculate the row & column totals and order them.

ncell(1) = n(1,1)
ncell(2) = n(1,2)
ncell(3) = n(2,1)
ncell(4) = n(2,2)
CALL order4(ncell)

ntot(1) = n(1,1) + n(1,2)
ntot(2) = n(2,1) + n(2,2)
ntot(3) = n(1,1) + n(2,1)
ntot(4) = n(1,2) + n(2,2)
CALL order4(ntot)

nall = ncell(1) + ncell(2) + ncell(3) + ncell(4)
IF (nall == 0) THEN
  WRITE(*, *) '** Call to HYPERG with total cell frequency = 0 **'
  prob = zero
  RETURN
END IF

!     Calculate hyperg as:

!       ntot(1)!   ntot(2)!    ntot(3)!    ntot(4)!        1
!       -------- . --------- . --------- . --------- . ---------
!        nall!     ncell(1)!   ncell(2)!   ncell(3)!   ncell(4)!

!     The order of multiplications and divisions minimizes the chance
!     of overflows or underflows without using logarithms.

prob = one
DO
  ended = .true.
  IF (nall > ntot(1)) THEN
    prob = prob / nall
    nall = nall - 1
    ended = .false.
  END IF

  IF (ntot(2) > ncell(1)) THEN
    prob = prob * ntot(2)
    ntot(2) = ntot(2) - 1
    ended = .false.
  END IF

  IF (ntot(3) > ncell(2)) THEN
    prob = prob * ntot(3)
    ntot(3) = ntot(3) - 1
    ended = .false.
  END IF

  IF (ntot(4) > ncell(3)) THEN
    prob = prob * ntot(4)
    ntot(4) = ntot(4) - 1
    ended = .false.
  END IF

  IF (ncell(4) > 1) THEN
    prob = prob / ncell(4)
    ncell(4) = ncell(4) - 1
    ended = .false.
  END IF
  IF (ended) EXIT
END DO

RETURN
END FUNCTION hyperg

SUBROUTINE order4(n)

!     Order 4 integers; largest first.

IMPLICIT NONE
INTEGER, INTENT(IN OUT) :: n(4)

!     Local variable
INTEGER :: nn

IF (n(1) < n(2)) THEN
  nn = n(1)
  n(1) = n(2)
  n(2) = nn
END IF

IF (n(3) < n(4)) THEN
  nn = n(3)
  n(3) = n(4)
  n(4) = nn
END IF

IF (n(2) < n(3)) THEN
  nn = n(2)
  n(2) = n(3)
  n(3) = nn
  IF (n(3) < n(4)) THEN
    nn = n(3)
    n(3) = n(4)
    n(4) = nn
  END IF
  IF (n(1) < n(2)) THEN
    nn = n(1)
    n(1) = n(2)
    n(2) = nn
    IF (n(2) < n(3)) THEN
      nn = n(2)
      n(2) = n(3)
      n(3) = nn
    END IF
  END IF
END IF

RETURN
END SUBROUTINE order4

SUBROUTINE alias(p, n, f, l)

! Set up the aliases for the method described in:

! Kronmal, R.A. & Peterson, A.V. (1979)
! `On the Alias Method for Generating Random Variables from a Discrete
! Distribution', The American Statistician, vol.33(4), 214-218.

! The algorithm improves slightly on the basic algorithm given in:

! Walker, A.J. (1977)
! `An Efficient Method for Generating Discrete Random Variables with General
! Distributions', ACM Transactions on Mathematical Software, vol.3, 253-256.

! Arguments:
! p(1:n)  INPUT   Contains the discrete distribution
!                 N.B. It must have a finite range
! n       INPUT
! f(1:n)  OUTPUT  The cut-off values for each value of the random variable
! l(1:n)  OUTPUT  The aliases (at least one will be undefined, in which case
!                 it is not needed as the corresponding f(i) >= 1.

REAL (dp), INTENT(IN)   :: p(:)
INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(OUT)  :: f(:)
INTEGER, INTENT(OUT)    :: l(:)

! Local variables

INTEGER    :: i, ig, is, gptr(n), j, k, sptr(n-1)
REAL (dp), PARAMETER  :: nearly_one = 1.0_dp - 100.0_dp*EPSILON(1.0_dp)

! Step 1
f(1:n) = n * p(1:n)

! Step 2
! G = set of i such that f(i) >= 1
! S = the others
ig = 0
is = 0
DO i = 1, n
  IF (f(i) < 1.0) THEN
    is = is + 1
    sptr(is) = i
  ELSE
    ig = ig + 1
    gptr(ig) = i
  END IF
END DO

! Step 3
! Main loop
DO
  IF (is == 0) EXIT

! Step 4
! Choose element k in G, and element j in S.
! We choose the last ones on each list.
  k = gptr(ig)
  j = sptr(is)
! This finalizes operations on element j, so we can remove it from S.
  is = is - 1

! Step 5
  l(j) = k

! Step 6
  f(k) = f(k) - (1.0 - f(j))

! Step 7
! f(k) may now be < 1.
! If so, remove it from G and add it to S.
  IF (f(k) < nearly_one) THEN
    ig = ig - 1
    is = is + 1
    sptr(is) = k
  END IF
END DO

RETURN
END SUBROUTINE alias

END MODULE random_hypergeometric

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

INTEGER, SAVE       :: iseed = 123456789

CONTAINS

SUBROUTINE h2pec(kk, nn1, nn2, iseed1, jx)

!  HYPERGEOMETRIC RANDOM VARIATE GENERATOR

!  METHOD
!     IF (MODE - MAX(0,KK-NN2) .LT. 10), USE THE INVERSE CDF.
!        OTHERWISE, USE ALGORITHM H2PE: ACCEPTANCE-REJECTION VIA
!        THREE REGION COMPOSITION.  THE THREE REGIONS ARE A
!        RECTANGLE, AND EXPONENTIAL LEFT AND RIGHT TAILS.
!     H2PE  REFERS TO HYPERGEOMETRIC-2 POINTS-EXPONENTIAL TAILS.
!     H2PEC REFERS TO H2PE AND "COMBINED."  THUS H2PE IS THE RESEARCH RESULT
!        AND H2PEC IS THE IMPLEMENTATION OF A COMPLETE USABLE ALGORITHM.

!  REFERENCE
!     VORATAS KACHITVICHYANUKUL AND BRUCE SCHMEISER,

!     "COMPUTER GENERATION OF HYPERGEOMETRIC RANDOM VARIATES,"
!     JOURNAL OF STATISTICAL COMPUTATION AND SIMULATION,
!     22(1985), 2, 1985, 127-145.

!  REQUIRED SUBPROGRAMS
!     AFC() : A DOUBLE-PRECISION FUNCTION TO EVALUATE
!                THE LOGARITHM OF THE FACTORIAL.
!     RAND(): A UNIFORM (0,1) RANDOM NUMBER GENERATOR.

!  ARGUMENTS
!     NN1   : NUMBER OF WHITE BALLS          (INPUT)
!     NN2   : NUMBER OF BLACK BALLS          (INPUT)
!     KK    : NUMBER OF BALLS TO BE DRAWN    (INPUT)
!     ISEED : RANDOM NUMBER SEED  (INPUT AND OUTPUT)
!     JX    : NUMBER OF WHITE BALLS DRAWN   (OUTPUT)

!  STRUCTURAL VARIABLES
!     REJECT: LOGICAL FLAG TO REJECT THE VARIATE GENERATE BY H2PE.
!     SETUP1: LOGICAL FLAG TO SETUP FOR NEW VALUES OF NN1 OR NN2.
!     SETUP2: LOGICAL FLAG TO SETUP FOR NEW VALUES OF KK.
!     IX    : INTEGER CANDIDATE VALUE.
!     M     : DISTRIBUTION MODE.
!     MINJX : DISTRIBUTION LOWER BOUND.
!     MAXJX : DISTRIBUTION UPPER BOUND.
!     KS    : SAVED VALUE OF KK FROM THE LAST CALL TO H2PEC.
!     N1S   : SAVED VALUE OF NN1 FROM THE LAST CALL TO H2PEC.
!     N2S   : SAVED VALUE OF NN2 FROM THE LAST CALL TO H2PEC.
!     K,N1,N2: ALTERNATE VARIABLES FOR KK, NN1, AND NN2
!                (ALWAYS (N1 .LE. N2) AND (K .LE. (N1+N2)/2)).
!     TN    : TOTAL NUMBER OF WHITE AND BLACK BALLS

!  INVERSE-TRANSFORMATION VARIABLES
!     CON   : NATURAL LOGARITHM  OF SCALE.
!     P     : CURRENT SCALED PROBABILITY FOR THE INVERSE CDF.
!     SCALE : A BIG CONSTANT (1.E25) USED TO SCALE THE
!                PROBABILITY TO AVOID NUMERICAL UNDERFLOW
!     U     : THE UNIFORM VARIATE BETWEEN (0, 1.E25).
!     W     : SCALED HYPERGEOMETRIC PROBABILITY OF MINJX.

!  H2PE VARIABLES
!     S     : DISTRIBUTION STANDARD DEVIATION.
!     D     : HALF THE AREA OF THE RECTANGLE.
!     XL    : LEFT END OF THE RECTANGLE.
!     XR    : RIGHT END OF THE RECTANGLE.
!     A     : A SCALING CONSTANT.
!     KL    : HIGHEST POINT OF THE LEFT-TAIL REGION.
!     KR    : HIGHEST POINT OF THE RIGHT-TAIL REGION.
!     LAMDL : RATE FOR THE LEFT EXPONENTIAL TAIL.
!     LAMDR : RATE FOR THE RIGHT EXPONENTIAL TAIL.
!     P1    : AREA OF THE RECTANGLE.
!     P2    : AREA OF THE LEFT EXPONENTIAL TAIL PLUS P1.
!     P3    : AREA OF THE RIGHT EXPONENTIAL TAIL PLUS P2.
!     U     : A UNIFORM (0,P3) RANDOM VARIATE USED FIRST TO SELECT
!                ONE OF THE THREE REGIONS AND THEN CONDITIONALLY TO
!                GENERATE A VALUE FROM THE REGION.
!     V     : U(0,1) RANDOM NUMBER USED TO GENERATE THE RANDOM
!                VALUE OR TO ACCEPT OR REJECT THE CANDIDATE VALUE.
!     F     : THE HEIGHT OF THE SCALED DENSITY FUNCTION USED IN THE
!                ACCEPT/REJECT DECISION WHEN BOTH M AND IX ARE SMALL.
!     I     : INDEX FOR EXPLICIT CALCULATION OF F FOR H2PE.

! THE FOLLOWING VARIABLES ARE TEMPORARY VARIABLES USED IN COMPUTING THE UPPER
! AND LOWER BOUNDS OF THE NATURAL LOGARITHM OF THE SCALED DENSITY.
! THE DETAILED DESCRIPTION IS GIVEN IN PROPOSITIONS 2 AND 3 OF THE APPENDIX IN
! THE REFERENCE.
!     Y, Y1, YM, YN, YK, NK, R, S, T, E, G, DG, GU, GL, XM, XN, XK, NM

!     Y     : PRELIMINARY CONTINUOUS CANDIDATE VALUE, FLOAT(IX)
!     UB    : UPPER BOUND FOR THE NATURAL LOGARITHM OF THE SCALED DENSITY.
!     ALV   : NATURAL LOGARITHM OF THE ACCEPT/REJECT VARIATE V.
!     DR, DS, DT, DE: ONE OF MANY TERMS SUBTRACTED FROM THE UPPER
!                BOUND TO OBTAIN THE LOWER BOUND ON THE NATURAL
!                LOGARITHM OF THE SCALED DENSITY.
!     DELTAU: A CONSTANT, THE VALUE 0.0034 IS OBTAINED BY SETTING
!                N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
!                THE FUNCTION DELTA_U IN LEMMA 1 AND ROUNDING THE
!                VALUE TO FOUR DECIMAL PLACES.
!     DELTAL: A CONSTANT, THE VALUE 0.0078 IS OBTAINED BY SETTING
!                N1 = N2 = 200, K = 199, M = 100, AND Y = 50 IN
!                THE FUNCTION DELTA_L IN LEMMA 1 AND ROUNDING THE
!                VALUE TO FOUR DECIMAL PLACES.

INTEGER, INTENT(IN)      :: kk
INTEGER, INTENT(IN)      :: nn1
INTEGER, INTENT(IN)      :: nn2
INTEGER, INTENT(IN OUT)  :: iseed1
INTEGER, INTENT(OUT)     :: jx

REAL (dp)      :: p, u, w, a, xl, xr
REAL           :: alv, d, dg, de, dr, ds, dt, e, f, g, gl, gu, kl, kr,  &
                  lamdl, lamdr, nk, nm, p1, p2, p3, r, s, t, ub, v,  &
                  xk, xm, xn, y, y1, yk, ym, yn
REAL, SAVE     :: tn
INTEGER        :: i, ix, k, n1, n2
LOGICAL, SAVE  :: reject, setup1, setup2
INTEGER, SAVE  :: ks = -1, n1s = -1, n2s = -1, m, minjx, maxjx
REAL (dp), PARAMETER  :: con = 57.56462733_dp, deltal = 0.0078_dp,  &
                         deltau = 0.0034_dp, scale = 1.0e+25_dp

!*****CHECK PARAMETER VALIDITY

IF ( nn1 < 0  .OR. nn2 < 0 .OR. kk  < 0 .OR. kk > nn1 + nn2 ) THEN
  jx     = -1
  RETURN
END IF
iseed = iseed1

!*****IF NEW PARAMETER VALUES, INITIALIZE

reject = .true.
setup1 = .false.
setup2 = .false.
IF (nn1 /= n1s .OR. nn2 /= n2s)  THEN
  setup1 = .true.
  setup2 = .true.
ELSE IF (kk /= ks)  THEN
  setup2 = .true.
END IF

IF (setup1)  THEN
  n1s   = nn1
  n2s   = nn2
  tn    = nn1 + nn2
  IF (nn1 <= nn2)  THEN
    n1 = nn1
    n2 = nn2
  ELSE
    n1 = nn2
    n2 = nn1
  END IF
END IF

IF (setup2)  THEN
  ks    = kk
  IF (kk+kk >= tn)  THEN
    k  = tn - kk
  ELSE
    k  = kk
  END IF
END IF

IF (setup1 .OR. setup2)  THEN
  m     = (k+1.) * (n1+1.) / (tn+2.)
  minjx = MAX (0, k-n2)
  maxjx = MIN (n1, k)
END IF

!*****GENERATE RANDOM VARIATE

IF (minjx == maxjx)  THEN

!        ...DEGENERATE DISTRIBUTION...

  ix      = maxjx
  RETURN
ELSE IF (m-minjx < 10)  THEN

!        ...INVERSE TRANSFORMATION...

  IF (setup1 .OR. setup2)  THEN
    IF (k < n2) THEN
      w = EXP (con + afc(n2) + afc(n1+n2-k) - afc(n2-k) - afc(n1+n2))
    ELSE
      w = EXP (con + afc(n1) + afc(k) - afc(k-n2) - afc(n1+n2))
    END IF
  END IF

  10 p  = w
  ix = minjx
  u  = rand () * scale
  20 IF (u > p)  THEN
    u  = u - p
    p  = p * (n1-ix)*(k-ix)
    ix = ix + 1
    p  = p / ix / (n2-k+ix)
    IF (ix > maxjx)  GO TO 10
    GO TO 20
  END IF
ELSE

!        ...H2PE...

  IF (setup1 .OR. setup2)  THEN
    s     = SQRT ((tn-k) * k * n1 * n2 / (tn-1) / tn /tn)

!           ...REMARK:  D IS DEFINED IN REFERENCE WITHOUT INT.
!           THE TRUNCATION CENTERS THE CELL BOUNDARIES AT 0.5

    d     = INT (1.5*s) + .5
    xl    = m - d + .5
    xr    = m + d + .5
    a     = afc(m) + afc(n1-m) + afc(k-m) + afc(n2-k+m)
    kl    = EXP (a - afc(INT(xl)) - afc(INT(n1-xl))  &
            - afc(INT(k-xl)) - afc(INT(n2-k+xl)))
    kr    = EXP (a - afc(INT(xr-1)) - afc(INT(n1-xr+1))  &
            - afc(INT(k-xr+1)) - afc(INT(n2-k+xr-1)))
    lamdl = -LOG (xl * (n2-k+xl) / (n1-xl+1) / (k-xl+1))
    lamdr = -LOG ((n1-xr+1) * (k-xr+1) / xr / (n2-k+xr))
    p1    = d + d
    p2    = p1 + kl / lamdl
    p3    = p2 + kr / lamdr
  END IF

  30 u    = rand () * p3
  v       = rand ()
  IF (u < p1)  THEN

!           ...RECTANGULAR REGION...

    ix    = xl + u
  ELSE IF (u <= p2)  THEN

!           ...LEFT TAIL...

    ix    = xl + LOG(v)/lamdl
    IF (ix < minjx)  GO TO 30
    v     = v * (u-p1) * lamdl
  ELSE

!           ...RIGHT TAIL...

    ix    = xr - LOG(v)/lamdr
    IF (ix > maxjx)  GO TO 30
    v     = v * (u-p2) * lamdr
  END IF

!        ...ACCEPTANCE/REJECTION TEST...

  IF (m < 100 .OR. ix <= 50)  THEN

!           ...EXPLICIT EVALUATION...

    f     = 1.0
    IF (m < ix)  THEN
      DO  i = m+1,ix
        f   = f * (n1-i+1) * (k-i+1) / (n2-k+i) / i
      END DO
    ELSE IF (m > ix)  THEN
      DO  i = ix+1,m
        f   = f * i * (n2-k+i) / (n1-i) / (k-i)
      END DO
    END IF
    IF (v <= f)  THEN
      reject = .false.
    END IF
  ELSE

!        ...SQUEEZE USING UPPER AND LOWER BOUNDS...

    y   = ix
    y1  = y + 1.
    ym  = y - m
    yn  = n1 - y + 1.
    yk  = k - y + 1.
    nk  = n2 - k + y1
    r   = -ym / y1
    s   = ym / yn
    t   = ym / yk
    e   = -ym / nk
    g   = yn * yk / (y1*nk) - 1.
    dg  = 1.
    IF (g < 0.) dg = 1.+g
    gu  = g * (1.+g*(-.5+g/3.))
    gl  = gu - .25 * (g*g)**2 / dg
    xm  = m + .5
    xn  = n1 - m + .5
    xk  = k - m + .5
    nm  = n2 - k + xm
    ub  = y * gu - m * gl + deltau + xm * r * (1.+r*(-.5+r/3.))  &
          + xn * s * (1.+s*(-.5+s/3.)) + xk * t * (1.+t*(-.5+t/3.))  &
          + nm * e * (1.+e*(-.5+e/3.))

!           ...TEST AGAINST UPPER BOUND...

    alv = LOG(v)
    IF (alv > ub)  THEN
      reject = .true.
    ELSE

!              ...TEST AGAINST LOWER BOUND...

      dr = xm * (r*r)**2
      IF (r < 0.)  dr = dr / (1.+r)
      ds = xn * (s*s)**2
      IF (s < 0.)  ds = ds / (1.+s)
      dt = xk * (t*t)**2
      IF (t < 0.)  dt = dt / (1.+t)
      de = nm * (e*e)**2
      IF (e < 0.)  de = de / (1.+e)
      IF (alv < ub-.25*(dr+ds+dt+de) +(y+m)*(gl-gu)-deltal) THEN
        reject = .false.
      ELSE

!                 ...STIRLING'S FORMULA TO MACHINE ACCURACY...

        IF (alv <= a - afc(ix) - afc(n1-ix) - afc(k-ix) - afc(n2-k+ix) ) THEN
          reject = .false.
        ELSE
          reject = .true.
        END IF
      END IF
    END IF
  END IF
  IF (reject)  GO TO 30
END IF

!*****RETURN APPROPRIATE VARIATE

IF (kk + kk >= tn)  THEN
  IF (nn1 > nn2)  THEN
    ix = kk - nn2 + ix
  ELSE
    ix =  nn1 - ix
  END IF
ELSE
  IF (nn1 > nn2)  ix = kk - ix
END IF
jx = ix

RETURN
END SUBROUTINE h2pec

FUNCTION afc(i) RESULT(fn_val)

!     FUNCTION TO EVALUATE LOGARITHM OF THE FACTORIAL I
!        IF (I .GT. 7), USE STIRLING'S APPROXIMATION
!        (It actually uses the less accurate De Moivre approximation)
!           OTHERWISE,  USE TABLE LOOKUP

INTEGER, INTENT(IN)  :: i
REAL (dp)            :: fn_val

REAL (dp) :: di

REAL (dp), PARAMETER  :: al(8) = (/ 0._dp, 0._dp, 0.6931471806_dp,  &
                         1.791759469_dp, 3.178053830_dp, 4.787491743_dp, &
                         6.579251212_dp, 8.525161361_dp /)

IF (i <= 7)  THEN
  fn_val = al(i+1)
ELSE
  di  = i
  fn_val = (di+0.5_dp) * LOG(di) - di + 0.08333333333333_dp/di  &
           - 0.00277777777777_dp/di/di/di  + 0.9189385332_dp
END IF

RETURN
END FUNCTION afc

FUNCTION rand() RESULT(fn_val)

!  UNIFORM RANDOM NUMBER GENERATOR
!  REFERENCE:  L. SCHRAGE,
!     "A MORE PORTABLE FORTRAN RANDOM NUMBER GENERATOR,"
!     ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, 5(1979), 132-138.

REAL                :: fn_val

INTEGER             :: xhi, xalo, leftlo, fhi, k
INTEGER, PARAMETER  :: a = 16807, b15 = 32768, b16 = 65536, p = 2147483647

xhi    = iseed / b16
xalo   = (iseed-xhi * b16) * a
leftlo = xalo/b16
fhi    = xhi * a + leftlo
k      = fhi / b15
iseed  = (((xalo - leftlo * b16) - p) + (fhi - k * b15) * b16) + k
IF (iseed < 0) iseed = iseed + p
fn_val = iseed * 4.656612875E-10

RETURN
END FUNCTION rand

END MODULE toms668

PROGRAM test_random_hyperg
! TEST 1
! ------
! Test the random generation of hypergeometric variables by generating
! the number of spades in a hand of 13 cards out of 52.
! 1 million replicates used.

USE random_hypergeometric
USE toms668
IMPLICIT NONE

REAL     :: t1, t2
INTEGER  :: freq(0:13), c, d, h, i, j, s

WRITE(*, *) '  TEST 1'
WRITE(*, *)

! First using r_hyperg
freq = 0
CALL CPU_TIME(t1)
DO i = 1, 1000000
  j = r_hyperg(52, 13, 13)
  freq(j) = freq(j) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by r_hyperg = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

! Now using h_alias
freq = 0
CALL CPU_TIME(t1)
DO i = 1, 1000000
  j = h_alias(52, 13, 13)
  freq(j) = freq(j) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by h_alias = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

! Now using TOMS algorithm 668

freq = 0
CALL CPU_TIME(t1)
DO i = 1, 1000000
  CALL h2pec(13, 13, 39, iseed, j)
  freq(j) = freq(j) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by TOMS668 = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

! TEST 2
! ------
! This tests the set-up time as the parameters change on every call.
! The number of clubs, diamonds, hearts and spades are found in a hand
! of 13 cards out of 52 by calling the random number generator 3 times
! with different parameters.

WRITE(*, *)
WRITE(*, *) '  TEST 2'
WRITE(*, *)

! First using r_hyperg
freq = 0
CALL CPU_TIME(t1)
DO i = 1, 100000
  c = r_hyperg(52, 13, 13)
  d = r_hyperg(39, 13, 13-c)
  h = r_hyperg(26, 13, 13-c-d)
  s = 13 - c - d - h
  freq(c) = freq(c) + 1
  freq(d) = freq(d) + 1
  freq(h) = freq(h) + 1
  freq(s) = freq(s) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by r_hyperg = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

! Now using h_alias

freq = 0
CALL CPU_TIME(t1)
DO i = 1, 100000
  c = h_alias(52, 13, 13)
  d = h_alias(39, 13, 13-c)
  h = h_alias(26, 13, 13-c-d)
  s = 13 - c - d - h
  freq(c) = freq(c) + 1
  freq(d) = freq(d) + 1
  freq(h) = freq(h) + 1
  freq(s) = freq(s) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by h_alias = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

! Now using TOMS algorithm 668

freq = 0
CALL CPU_TIME(t1)
DO i = 1, 100000
  CALL h2pec(13, 13, 39, iseed, c)
  CALL h2pec(13-c, 13, 26, iseed, d)
  CALL h2pec(13-c-d, 13, 13, iseed, h)
  s = 13 - c - d - h
  freq(c) = freq(c) + 1
  freq(d) = freq(d) + 1
  freq(h) = freq(h) + 1
  freq(s) = freq(s) + 1
END DO
CALL CPU_TIME(t2)
WRITE(*, '(a, f8.2, a)') ' Time taken by TOMS668 = ', t2-t1, 'secs.'
WRITE(*, '(a/9i7/5i7)') ' Frequencies', freq

STOP
END PROGRAM test_random_hyperg


! test sln of 2d diffusion equation
! under Crank-Nicholson discritisation
! and Gauss Seidel relaxation

program implicit1

  implicit none

  integer, parameter :: num = selected_real_kind(p=15)
  integer :: out_unit = 10

  integer :: nx = 128
  integer :: ny = 128

  real(num) :: x_min = 0.0_num
  real(num) :: x_max = 1.0_num
  real(num) :: y_min = 0.0_num
  real(num) :: y_max = 1.0_num

  real(num) :: time = 0.0_num
  real(num) :: t_end = 0.02_num

  real(num) :: k = 1.0_num
  real(num) :: phi2 = 2.0_num !max val
  real(num) :: phi1 = 1.0_num !baseline

  real(num) :: CFL = 2.0_num

  real(num) :: tol = 1e-12_num

  integer :: tstep = 0
  integer :: rstep = 0
  integer :: ix, iy
  real(num) :: dx, dy
  real(num) :: r,xx,yy

  real(num) :: dt
  real(num), dimension(:), allocatable :: x, y
  real(num), dimension(:,:), allocatable :: phi, phi_an, f

  real(num) :: L_phi
  real(num) :: alpha, beta

  real(num) :: L2

  allocate(x(0:nx+1))  ! cell center (cc) - counts from 1 to nx
  allocate(y(0:ny+1))  ! cell center (cc) - counts from 1 to ny
                        ! ONE GUARD CELL FOR THIS PROBLEM

  dx = (x_max - x_min) / REAL(nx,num)
  x(0) = x_min - dx/2.0_num
  do ix = 1, nx+1
    x(ix) = x(ix-1) + dx
  end do

  dy = (y_max - y_min) / REAL(ny,num)
  y(0) = y_min - dy/2.0_num
  do iy = 1, ny+1
  y(iy) = y(iy-1) + dy
  end do

  if (dy /= dx) then
    print *, 'Warning: dy /= dx set. Has not yet being generalised.'
    print *, 'Terminating'
    STOP
  end if

  allocate(phi(0:nx+1,0:ny+1))
  allocate(phi_an(0:nx+1,0:ny+1))

  do ix = 0, nx + 1
  do iy = 0, ny + 1
    xx = x(ix) - 0.5_num
    yy = y(iy) - 0.5_num
    r = sqrt(xx**2 + yy**2)
    phi(ix,iy) = (phi2-phi1) * exp(-0.25_num * r**2 / k / 0.001_num) + phi1
! 1.0_num + amp * exp(-r**2/ (2.0_num *(fwtm/4.29193_num)**2))
  enddo
  enddo

!  GOTO 1 ! uncomment to just dump initial condiiton and check it, bypassing the loop

  allocate(f(1:nx,1:ny))

  ! evolution loop

  time = 0.0_num

  do
    tstep = tstep + 1
    if (time > t_end) exit

    dt = CFL * dx**2 / k

    alpha = 1.0_num
    beta = dt * k / 2.0_num

    do ix = 1, nx
    do iy = 1, ny

      ! function based on laplacian of phi at the previous time level
      ! - dont update during relaxation

      L_phi = (phi(ix+1,iy) - 2.0_num*phi(ix,iy) + phi(ix-1,iy)) / dx**2 + &
        & (phi(ix,iy+1) - 2.0_num*phi(ix,iy) + phi(ix,iy-1)) / dy**2

      f(ix,iy) = phi(ix,iy) + 0.5_num * dt * k * L_phi

    enddo
    enddo

    !forget initial phi ?
    !phi = 0.0_num

    !GS relaxation loop

    do
      rstep = rstep + 1

      ! odd iteration
      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 1) then

          ! set to the adjacent phi values first, then
          phi(ix,iy) = phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1)
          phi(ix,iy) = (f(ix,iy) + beta * phi(ix,iy) / dx**2) / &
            & (alpha + 4.0_num * beta / dx**2)

        endif
      end do
      end do

      ! even iteration

      do iy = 1, ny
      do ix = 1, nx
        if (modulo(ix+iy,2) == 0) then
          phi(ix,iy) = phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1)
          phi(ix,iy) = (f(ix,iy) + beta * phi(ix,iy) / dx**2) / &
            & (alpha + 4.0_num * beta / dx**2)
        endif
      end do
      end do

      ! Apply boundary conditions on phi's ghost cells here
      ! homogenous Neumann BC

      phi(0,:) = phi(1,:)
      phi(nx+1,:) = phi(nx,:)
      phi(:,0) = phi(:,1)
      phi(:,ny+1) = phi(:,ny)

      ! Apply periodic boundary conditions on phi's ghost cells

      !phi(0,:) = phi(nx,:)
      !phi(nx+1,:) = phi(1,:)
      !phi(:,0) = phi(:,ny)
      !phi(:,ny+1) = phi(:,1)

      L2 = 0.0_num
      do iy = 1, ny
      do ix = 1, nx

        !Laplacian of phi at new time level / this relaxaed state

        L_phi = (phi(ix+1,iy) - 2.0_num*phi(ix,iy) + phi(ix-1,iy)) / dx**2 + &
          & (phi(ix,iy+1) - 2.0_num*phi(ix,iy) + phi(ix,iy-1)) / dy**2

        !residual
        L2 = L2 + abs(f(ix,iy)-(alpha*phi(ix,iy)-beta*L_phi))**2
      end do
      end do
      L2 = sqrt( L2 / REAL(nx*ny,num))

!      print *,'time',time,'rstep',rstep,'L2',L2

      if (L2 <= tol) exit
    enddo

    print *,'time', time,'tstep',tstep
    print *,'took', rstep,'iterations to converge to (residual) L2=',L2

    time = time + dt
  enddo

  !the analytical solution
  do ix = 1,nx
  do iy = 1,ny
    xx = x(ix) - 0.5_num
    yy = y(iy) - 0.5_num
    r = sqrt(xx**2 + yy**2)
    phi_an(ix,iy) = (phi2-phi1) * (0.001_num / (time+0.001_num)) &
      & * exp(-0.25_num * r**2 / k / (0.001_num + time)) + phi1
  enddo
  enddo

  !calculate the L2 norm against the analytical solution

  L2 = 0.0_num

  do ix = 1, nx
  do iy = 1, ny
    L2 = L2 + abs(phi_an(ix,iy)-phi(ix,iy))**2
  enddo
  enddo
  L2 = sqrt( L2 / REAL(nx*ny,num))

  print *,'L2 error norm agains analtical solution is',L2

1 CONTINUE

  call execute_command_line("rm -rf *.dat *.png")
    !dont want to stream to existing files

  open(out_unit, file="x.dat", access="stream")
  write(out_unit) x(1:nx)
  close(out_unit)

  open(out_unit, file="y.dat", access="stream")
  write(out_unit) y(1:ny)
  close(out_unit)

  open(out_unit, file="phi.dat", access="stream")
  write(out_unit) phi(1:nx,1:ny)
  close(out_unit)

  open(out_unit, file="phi_an.dat", access="stream")
  write(out_unit) phi_an(1:nx,1:ny)
  close(out_unit)

  !calculate the difference of phi from the analytical solution
  ! (just call the difference phi to avoid allocating a new array)
!  do ix = 1, nx
!  do iy = 1, ny
!    phi(ix,iy) = phi(ix,iy) -
!  enddo
!  enddo

  call execute_command_line("python plot.py")
  call execute_command_line("rm -rf *.dat")

end program implicit1


      MODULE FACTORSTUFF	!This protocol evades the need for multiple parameters, or COMMON, or one shapeless main line...
Concocted by R.N.McLean, MMXV.
       INTEGER LOTS,ILIMIT		!Some bounds.
       PARAMETER (ILIMIT = 2147483647)	!Computer arithmetic is not with real numbers.
       PARAMETER (LOTS = 22000)	!Nor is computer storage infinite.
       INTEGER KNOWNSUM(LOTS)		!Calculate these once as multiple references are expected.
       CONTAINS			!Assistants.
        INTEGER FUNCTION SUMF(N)	!Sum of the proper divisors of N.
         INTEGER N			!The number in question.
         INTEGER S,F,F2,INC,BOOST	!Assistants.
          IF (N.LE.LOTS) THEN		!If we're within reach,
            SUMF = KNOWNSUM(N)			!The result is to hand.
           ELSE			!Otherwise, some on-the-spot effort ensues.
Could use SUMF in place of S, but some compilers have been confused by such usage.
            S = 1			!1 is always a factor of N, but N is deemed not.
            F = 1			!Prepare a crude search for factors.
            INC = 1			!One by plodding one.
            IF (MOD(N,2) .EQ. 1) INC = 2!Ah, but an odd number cannot have an even number as a divisor.
    1       F = F + INC			!So half the time we can doubleplod.
            F2 = F*F				!Up to F2 < N rather than F < SQRT(N) and worries over inexact arithmetic.
            IF (F2 .LT. N) THEN			!F2 = N handled below.
              IF (MOD(N,F) .EQ. 0) THEN		!Does F divide N?
                BOOST = F + N/F			!Yes. The divisor and its counterpart.
                IF (S .GT. ILIMIT - BOOST) GO TO 666	!Would their augmentation cause an overflow?
                S = S + BOOST			!No, so count in the two divisors just discovered.
              END IF				!So much for a divisor discovered.
              GO TO 1				!Try for another.
            END IF			!So much for the horde.
            IF (F2 .EQ. N) THEN	!Special case: N may be a perfect square, not necessarily of a prime number.
              IF (S .GT. ILIMIT - F) GO TO 666	!It is. And it too might cause overflow.
              S = S + F			!But if not, count F once only.
            END IF			!All done.
            SUMF = S			!This is the result.
          END IF			!Whichever way obtained,
         RETURN			!Done.
Cannot calculate the sum, because it exceeds the integer limit.
  666     SUMF = -666		!An expression of dismay that the caller will notice.
        END FUNCTION SUMF	!Alternatively, find the prime factors, and combine them...
         SUBROUTINE PREPARESUMF	!Initialise the KNOWNSUM array.
Convert the Sieve of Eratoshenes to have each slot contain the sum of the proper divisors of its slot number.
Changes to instead count the number of factors, or prime factors, etc. would be simple enough.
         INTEGER F		!A factor for numbers such as 2F, 3F, 4F, 5F, ...
          KNOWNSUM(1) = 0		!Proper divisors of N do not include N.
          KNOWNSUM(2:LOTS) = 1		!So, although 1 is a proper divisor of all N, 1 is excluded for itself.
          DO F = 2,LOTS/2		!Step through all the possible divisors of numbers not exceeding LOTS.
            FOR ALL(I = F + F:LOTS:F) KNOWNSUM(I) = KNOWNSUM(I) + F	!And augment each corresponding slot.
          END DO			!Different divisors can hit the same slot. For instance, 6 by 2 and also by 3.
        END SUBROUTINE PREPARESUMF	!Could alternatively generate all products of prime numbers.
      END MODULE FACTORSTUFF	!Enough assistants.
       PROGRAM AMICABLE		!Seek N such that SumF(SumF(N)) = N, for N up to 20,000.
       USE FACTORSTUFF		!This should help.
       INTEGER I,N		!Steppers.
       INTEGER S1,S2		!Sums of factors.
        CALL PREPARESUMF		!Values for every N up to the search limit will be called for at least once.
c        WRITE (6,66) (I,KNOWNSUM(I), I = 1,48)
c   66   FORMAT (10(I3,":",I5,"|"))
        DO N = 2,20000		!Step through the specified search space.
          S1 = SUMF(N)			!Only even numbers appear in the results, but check every one anyway.
          IF (S1 .EQ. N) THEN		!Catch a tight loop.
            WRITE (6,*) "Perfect!!",N	!Self amicable! Would otherwise appear as Amicable! n,n.
          ELSE IF (S1 .GT. N) THEN	!Look for a pair going upwards only.
            S2 = SUMF(S1)		!Since otherwise each would appear twice.
            IF (S2.EQ.N) WRITE (6,*) "Amicable!",N,S1	!Aha!
          END IF			!So much for that candidate.
        END DO			!On to the next.
      END			!Done.


Program Ejemplo5Bis

!***********************************************************************!
!  Programa Ejemplo5Bis																									!
!																																				!
!				Programa Creado por Edgardo Bonzi																!
!							edgardobonzi@gmail.com																		!
!																																				!
!								Marzo 23, 2015																					!
!								Version 0.1																							!
!																																				!
!	Ejemplo creado para mostrar el uso del comando "RESULT" en las 				!
!	funciones e "INTERFACE"																								!
!																																				!
!	Mostraremos el uso del TYPE Complex, nuemeros complejos intrinsecos		!
!	Y del uso de salidas de estructuras en las funciones, como ser				!
!															vectores																	!
!																																				!
! Una declaracion INTERFACE enumera todos las caracteristicas de				!
! procedimientos externos, por lo que el compilador puede confirmar si	!
! las llamadas de los subprogramas son correctos o no.									!
!																																				!
! El compilador verifica que el numero, tipos y atributos de los				!
! argumentos en la ! llamada del subprograma son consistentes con los		!
! declarados en la interfaz.																						!
!																																				!
! La declaracion INTERFACE tambion define los nombres a utilizar como		!
! palabras clave de argumentos.																					!
!																																				!
!	Esta metodo es conveniente reemplazarlo por el uso de Modulos					!																																	!
!																																				!
!***********************************************************************!

IMPLICIT NONE

Real(kind=8),Dimension(3) :: A, B, Salida
Complex(kind=8) :: Z, Y

INTERFACE
! INTERFACE donde definimos la operacion Producto_Cruz para Vectores
! *****************************************************************!

Function Producto_Cruz(a,b)
Real(kind=8), Dimension(3)::Producto_Cruz
Real(kind=8), Dimension(3), intent(in)::a,b
End Function Producto_Cruz

END INTERFACE

! Aplicacion simple de TYPE Complex
! ********************************!

Print*, 'Ingrese un numero complejo, de la forma "(a,b)" '

Read (*,*) Z
!Z = (1, 3)

Print*, 'Ingrese otro numero complejo, de la forma "(a,b)" '

Read (*,*) Y
!Y = (2, 4)

Print*, 'Estos son los dato ingresados :', Z, Y

Print*, 'Multiplicacion inteligente de Z * Y: ', Z * Y

Print*, 'Suma inteligente de Z + Y: ', Z + Y

! Aqui usaremos vectores en 3D
! ***************************!
Print*, '  '
Print *, 'Por favor ingrese tres numeros componentes del primer vector'

Read *, A

Print *, 'Por favor ingrese tres numeros componentes del segundo vector'

Read *, B

Salida = producto_cruz(A,B)

Print*, 'A x B', Salida

Salida = producto_cruz(B,A)

Print*, 'B x A', Salida

End Program Ejemplo5Bis

Function producto_cruz(a,b) Result(vector)

! Definici�n de la Funci�n Prodcuto Cruz con
! salida como resultado de un vector 3D
!
! *****************************************!

IMPLICIT NONE

Real(kind=8),Dimension(3),Intent(in)::a,b
Real(kind=8),Dimension(3) :: vector

vector(1) = a(2) * b(3) - a(3) * b(2)
vector(2) = a(3) * b(1) - a(1) * b(3)
vector(3) = a(1) * b(2) - a(2) * b(1)

End Function producto_cruz


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     Purpose:
!
!     Program to illustrate the use of subroutine hwsplr to solve
!     the equation
!
!     (1/r)(d/dr)(r*(du/dr)) + (1/r**2)(d/dtheta)(du/dtheta) = 16*r**2
!
!     on the quarter-disk 0 < r < 1, 0 < theta < pi/2 with
!     with the boundary conditions
!
!     u(1, theta) = 1 - cos(4*theta), 0 <= theta <= 1
!
!     and
!
!     (du/dtheta)(r, 0) = (du/dtheta)(r, pi/2) = 0,  0 <= r <= 1.
!
!     (note that the solution u is unspecified at r = 0.)
!          the r-interval will be divided into 50 panels and the
!     theta-interval will be divided into 48 panels.
!
!
!     from dimension statement we get value of idimf.
!
program test_hwsplr

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter    :: m = 50, n = 48
    integer(ip), parameter    :: idimf = 100
    integer(ip), parameter    :: mp1 = m + 1, np1 = n + 1
    integer(ip)               :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)                  :: f(idimf, m), theta(np1)
    real(wp), dimension (mp1) :: bdc, bdd, r
    real(wp), dimension(1)    :: bda, bdb
    real(wp)                  :: a, b, c, d, elmbda, pertrb
    real(wp), parameter       :: ZERO = 0.0_wp, ONE = 1.0_wp, FOUR = 4.0_wp

    ! Set domain
    a = ZERO
    b = ONE
    c = ZERO
    d = HALF_PI

    ! Set boundary conditions
    mbdcnd = 5
    nbdcnd = 3

    ! Set helmholtz constant
    elmbda = ZERO

    ! Generate and store grid points for the purpose of computing
    ! boundary data and the right side of the poisson equation.
    do i = 1, mp1
        r(i) = real(i - 1, kind=wp)/m
    end do

    do j = 1, np1
        theta(j) = real(j - 1, kind=wp) * (HALF_PI/n)
    end do

    ! Generate boundary data.
    ! In our example, bda and bdb are 1-dimensional dummy variables.
    bdc = ZERO
    bdd = ZERO

    ! Generate right hand side of equation
    block
        real(wp), parameter :: SIXTEEN = 16.0_wp

        do j = 1, np1
            f(mp1, j) = ONE - cos(FOUR * theta(j))
        end do

        do i = 1, m
            f(i, :np1) = SIXTEEN * r(i)**2
        end do
    end block

    ! Solve 2D Helmholtz in polar coordinates on centered grid
    call hwsplr(a, b, m, mbdcnd, bda, bdb, c, d, n, nbdcnd, bdc, bdd, &
        elmbda, f, idimf, pertrb, ierror)

    ! Compute discretization error. The exact solution is
    !
    ! u(r,theta) = (r**4)*(1 - cos(4*theta))
    block
        real(wp), parameter :: KNOWN_ERROR = 0.619134227874629e-003
        real(wp) :: discretization_error, exact_solution(mp1, np1)

        do j = 1, np1
            do i = 1, mp1
                exact_solution(i,j) = (r(i)**4)*(ONE-cos(FOUR * theta(j)))
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:mp1,:np1)))

        call check_output('hwsplr', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_hwsplr


c  To get dgamma,  "send dgamma from fnlib".
c  To get d1mach, mail netlib
c       send d1mach from core
c
      subroutine gaussq(kind, n, alpha, beta, kpts, endpts, b, t, w)
c
c           this set of routines computes the nodes t(j) and weights
c        w(j) for gaussian-type quadrature rules with pre-assigned
c        nodes.  these are used when one wishes to approximate
c
c                 integral (from a to b)  f(x) w(x) dx
c
c                              n
c        by                   sum w  f(t )
c                             j=1  j    j
c
c        (note w(x) and w(j) have no connection with each other.)
c        here w(x) is one of six possible non-negative weight
c        functions (listed below), and f(x) is the
c        function to be integrated.  gaussian quadrature is particularly
c        useful on infinite intervals (with appropriate weight
c        functions), since then other techniques often fail.
c
c           associated with each weight function w(x) is a set of
c        orthogonal polynomials.  the nodes t(j) are just the zeroes
c        of the proper n-th degree polynomial.
c
c     input parameters (all real numbers are in double precision)
c
c        kind     an integer between 1 and 6 giving the type of
c                 quadrature rule:
c
c        kind = 1:  legendre quadrature, w(x) = 1 on (-1, 1)
c        kind = 2:  chebyshev quadrature of the first kind
c                   w(x) = 1/sqrt(1 - x*x) on (-1, +1)
c        kind = 3:  chebyshev quadrature of the second kind
c                   w(x) = sqrt(1 - x*x) on (-1, 1)
c        kind = 4:  hermite quadrature, w(x) = exp(-x*x) on
c                   (-infinity, +infinity)
c        kind = 5:  jacobi quadrature, w(x) = (1-x)**alpha * (1+x)**
c                   beta on (-1, 1), alpha, beta .gt. -1.
c                   note: kind=2 and 3 are a special case of this.
c        kind = 6:  generalized laguerre quadrature, w(x) = exp(-x)*
c                   x**alpha on (0, +infinity), alpha .gt. -1
c
c        n        the number of points used for the quadrature rule
c        alpha    real parameter used only for gauss-jacobi and gauss-
c                 laguerre quadrature (otherwise use 0.d0).
c        beta     real parameter used only for gauss-jacobi quadrature--
c                 (otherwise use 0.d0)
c        kpts     (integer) normally 0, unless the left or right end-
c                 point (or both) of the interval is required to be a
c                 node (this is called gauss-radau or gauss-lobatto
c                 quadrature).  then kpts is the number of fixed
c                 endpoints (1 or 2).
c        endpts   real array of length 2.  contains the values of
c                 any fixed endpoints, if kpts = 1 or 2.
c        b        real scratch array of length n
c
c     output parameters (both double precision arrays of length n)
c
c        t        will contain the desired nodes.
c        w        will contain the desired weights w(j).
c
c     underflow may sometimes occur, but is harmless.
c
c     references
c        1.  golub, g. h., and welsch, j. h., "calculation of gaussian
c            quadrature rules," mathematics of computation 23 (april,
c            1969), pp. 221-230.
c        2.  golub, g. h., "some modified matrix eigenvalue problems,"
c            siam review 15 (april, 1973), pp. 318-334 (section 7).
c        3.  stroud and secrest, gaussian quadrature formulas, prentice-
c            hall, englewood cliffs, n.j., 1966.
c
c        original version 20 jan 1975 from stanford
c        modified 21 dec 1983 by eric grosse
c          imtql2 => gausq2
c          hex constant => d1mach (from core library)
c          compute pi using datan
c          removed accuracy claims, description of method
c          added single precision version
c
      double precision b(n), t(n), w(n), endpts(2), muzero, t1,
     x gam, solve, dsqrt, alpha, beta
c

ccc      print *, kind, n, alpha, beta, kpts, endpts

      call class (kind, n, alpha, beta, b, t, muzero)
c
c           the matrix of coefficients is assumed to be symmetric.
c           the array t contains the diagonal elements, the array
c           b the off-diagonal elements.
c           make appropriate changes in the lower right 2 by 2
c           submatrix.
c
      if (kpts.eq.0)  go to 100
      if (kpts.eq.2)  go to  50
c
c           if kpts=1, only t(n) must be changed
c
      t(n) = solve(endpts(1), n, t, b)*b(n-1)**2 + endpts(1)
      go to 100
c
c           if kpts=2, t(n) and b(n-1) must be recomputed
c
   50 gam = solve(endpts(1), n, t, b)
      t1 = ((endpts(1) - endpts(2))/(solve(endpts(2), n, t, b) - gam))
      b(n-1) = dsqrt(t1)
      t(n) = endpts(1) + gam*t1
c
c           note that the indices of the elements of b run from 1 to n-1
c           and thus the value of b(n) is arbitrary.
c           now compute the eigenvalues of the symmetric tridiagonal
c           matrix, which has been modified as necessary.
c           the method used is a ql-type method with origin shifting
c
  100 w(1) = 1.0d0
      do 105 i = 2, n
  105    w(i) = 0.0d0
c
      call gausq2 (n, t, b, w, ierr)
      do 110 i = 1, n
  110    w(i) = muzero * w(i) * w(i)
c
      return
      end
c
c
c
      double precision function solve(shift, n, a, b)
c
c       this procedure performs elimination to solve for the
c       n-th component of the solution delta to the equation
c
c             (jn - shift*identity) * delta  = en,
c
c       where en is the vector of all zeroes except for 1 in
c       the n-th position.
c
c       the matrix jn is symmetric tridiagonal, with diagonal
c       elements a(i), off-diagonal elements b(i).  this equation
c       must be solved to obtain the appropriate changes in the lower
c       2 by 2 submatrix of coefficients for orthogonal polynomials.
c
c
      double precision shift, a(n), b(n), alpha
c
      alpha = a(1) - shift
      nm1 = n - 1
      do 10 i = 2, nm1
   10    alpha = a(i) - shift - b(i-1)**2/alpha
      solve = 1.0d0/alpha
      return
      end
c
c
c
      subroutine class(kind, n, alpha, beta, b, a, muzero)
c
c           this procedure supplies the coefficients a(j), b(j) of the
c        recurrence relation
c
c             b p (x) = (x - a ) p   (x) - b   p   (x)
c              j j            j   j-1       j-1 j-2
c
c        for the various classical (normalized) orthogonal polynomials,
c        and the zero-th moment
c
c             muzero = integral w(x) dx
c
c        of the given polynomial's weight function w(x).  since the
c        polynomials are orthonormalized, the tridiagonal matrix is
c        guaranteed to be symmetric.
c
c           the input parameter alpha is used only for laguerre and
c        jacobi polynomials, and the parameter beta is used only for
c        jacobi polynomials.  the laguerre and jacobi polynomials
c        require the gamma function.
c
      double precision a(n), b(n), muzero, alpha, beta
      double precision abi, a2b2, dgamma, pi, dsqrt, ab
c
      pi = 4.0d0 * datan(1.0d0)
      nm1 = n - 1
      go to (10, 20, 30, 40, 50, 60), kind
c
c              kind = 1:  legendre polynomials p(x)
c              on (-1, +1), w(x) = 1.
c
   10 muzero = 2.0d0
      do 11 i = 1, nm1
         a(i) = 0.0d0
         abi = i
   11    b(i) = abi/dsqrt(4*abi*abi - 1.0d0)
      a(n) = 0.0d0
      return
c
c              kind = 2:  chebyshev polynomials of the first kind t(x)
c              on (-1, +1), w(x) = 1 / sqrt(1 - x*x)
c
   20 muzero = pi
      do 21 i = 1, nm1
         a(i) = 0.0d0
   21    b(i) = 0.5d0
      b(1) = dsqrt(0.5d0)
      a(n) = 0.0d0
      return
c
c              kind = 3:  chebyshev polynomials of the second kind u(x)
c              on (-1, +1), w(x) = sqrt(1 - x*x)
c
   30 muzero = pi/2.0d0
      do 31 i = 1, nm1
         a(i) = 0.0d0
   31    b(i) = 0.5d0
      a(n) = 0.0d0
      return
c
c              kind = 4:  hermite polynomials h(x) on (-infinity,
c              +infinity), w(x) = exp(-x**2)
c
   40 muzero = dsqrt(pi)
      do 41 i = 1, nm1
         a(i) = 0.0d0
   41    b(i) = dsqrt(i/2.0d0)
      a(n) = 0.0d0
      return
c
c              kind = 5:  jacobi polynomials p(alpha, beta)(x) on
c              (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and
c              beta greater than -1
c
   50 ab = alpha + beta
      abi = 2.0d0 + ab
      muzero = 2.0d0 ** (ab + 1.0d0) * dgamma(alpha + 1.0d0) * dgamma(
     x beta + 1.0d0) / dgamma(abi)
      a(1) = (beta - alpha)/abi
      b(1) = dsqrt(4.0d0*(1.0d0 + alpha)*(1.0d0 + beta)/((abi + 1.0d0)*
     1  abi*abi))
      a2b2 = beta*beta - alpha*alpha
      do 51 i = 2, nm1
         abi = 2.0d0*i + ab
         a(i) = a2b2/((abi - 2.0d0)*abi)
   51    b(i) = dsqrt (4.0d0*i*(i + alpha)*(i + beta)*(i + ab)/
     1   ((abi*abi - 1)*abi*abi))
      abi = 2.0d0*n + ab
      a(n) = a2b2/((abi - 2.0d0)*abi)
      return
c
c              kind = 6:  laguerre polynomials l(alpha)(x) on
c              (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater
c              than -1.
c
   60 muzero = dgamma(alpha + 1.0d0)
      do 61 i = 1, nm1
         a(i) = 2.0d0*i - 1.0d0 + alpha
   61    b(i) = dsqrt(i*(i + alpha))
      a(n) = 2.0d0*n - 1 + alpha
      return
      end
c
c
      subroutine gausq2(n, d, e, z, ierr)
c
c     this subroutine is a translation of an algol procedure,
c     num. math. 12, 377-383(1968) by martin and wilkinson,
c     as modified in num. math. 15, 450(1970) by dubrulle.
c     handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).
c     this is a modified version of the 'eispack' routine imtql2.
c
c     this subroutine finds the eigenvalues and first components of the
c     eigenvectors of a symmetric tridiagonal matrix by the implicit ql
c     method.
c
c     on input:
c
c        n is the order of the matrix;
c
c        d contains the diagonal elements of the input matrix;
c
c        e contains the subdiagonal elements of the input matrix
c          in its first n-1 positions.  e(n) is arbitrary;
c
c        z contains the first row of the identity matrix.
c
c      on output:
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1, 2, ..., ierr-1;
c
c        e has been destroyed;
c
c        z contains the first components of the orthonormal eigenvectors
c          of the symmetric tridiagonal matrix.  if an error exit is
c          made, z contains the eigenvectors associated with the stored
c          eigenvalues;
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     ------------------------------------------------------------------
c
      integer i, j, k, l, m, n, ii, mml, ierr
      real*8 d(n), e(n), z(n), b, c, f, g, p, r, s, machep
      real*8 dsqrt, dabs, dsign, d1mach
c
      machep=d1mach(4)
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      e(n) = 0.0d0
      do 240 l = 1, n
         j = 0
c     :::::::::: look for small sub-diagonal element ::::::::::
  105    do 110 m = l, n
            if (m .eq. n) go to 120
            if (dabs(e(m)) .le. machep * (dabs(d(m)) + dabs(d(m+1))))
     x         go to 120
  110    continue
c
  120    p = d(l)
         if (m .eq. l) go to 240
         if (j .eq. 30) go to 1000
         j = j + 1
c     :::::::::: form shift ::::::::::
         g = (d(l+1) - p) / (2.0d0 * e(l))
         r = dsqrt(g*g+1.0d0)
         g = d(m) - p + e(l) / (g + dsign(r, g))
         s = 1.0d0
         c = 1.0d0
         p = 0.0d0
         mml = m - l
c
c     :::::::::: for i=m-1 step -1 until l do -- ::::::::::
         do 200 ii = 1, mml
            i = m - ii
            f = s * e(i)
            b = c * e(i)
            if (dabs(f) .lt. dabs(g)) go to 150
            c = g / f
            r = dsqrt(c*c+1.0d0)
            e(i+1) = f * r
            s = 1.0d0 / r
            c = c * s
            go to 160
  150       s = f / g
            r = dsqrt(s*s+1.0d0)
            e(i+1) = g * r
            c = 1.0d0 / r
            s = s * c
  160       g = d(i+1) - p
            r = (d(i) - g) * s + 2.0d0 * c * b
            p = s * r
            d(i+1) = g + p
            g = c * r - b
c     :::::::::: form first component of vector ::::::::::
            f = z(i+1)
            z(i+1) = s * z(i) + c * f
  200       z(i) = c * z(i) - s * f
c
         d(l) = d(l) - p
         e(l) = g
         e(m) = 0.0d0
         go to 105
  240 continue
c
c     :::::::::: order eigenvalues and eigenvectors ::::::::::
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
c
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
c
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
         p = z(i)
         z(i) = z(k)
         z(k) = p
  300 continue
c
      go to 1001
c     :::::::::: set error -- no convergence to an
c                eigenvalue after 30 iterations ::::::::::
 1000 ierr = l
 1001 return
c     :::::::::: last card of gausq2 ::::::::::
      end