       SUBROUTINE jacob3(cartd,deriv,detj,elcod,elem,nnode,istop)
!*********************************************************************
!
!**** this SUBROUTINE evaluates the jacobian matrix and the cartesian
!     shape function derivatives
!
!*********************************************************************
      USE lispa0
      IMPLICIT NONE

      INTEGER (kind=4), PARAMETER :: ndime=2
      INTEGER (kind=4) elem,nnode,istop
      REAL    (kind=8) cartd(nnode,ndime),deriv(nnode,ndime),detj,      &
                       elcod(ndime,nnode)

      REAL    (kind=8) jaci(ndime,ndime) ,jacm(ndime,ndime)

!     ***  create jacobian matrix jacm

      jacm = MATMUL(elcod,deriv) !jacm(i,j) = d[x(i)]/d[xita(j)]

!     ***  calculate determinant and inverse of jacobian matrix

      detj = jacm(1,1)*jacm(2,2) - jacm(1,2)*jacm(2,1)
      IF(detj <= 0) THEN
        WRITE(*,"(//, '  PROGRAM halted in SUBROUTINE jacob3')")
        WRITE(*,"(11x,' zero or negative area')")
        WRITE(*,"(11x,' element number ',i5)") elem
        WRITE(*,"(2e15.4)") elcod,detj
        WRITE(lures,"(//, '  PROGRAM halted in SUBROUTINE jacob3')",ERR=9999)
        WRITE(lures,"(11x,' zero or negative area')",ERR=9999)
        WRITE(lures,"(11x,' element number ',i5)",ERR=9999) elem
        WRITE(lures,"(2e15.4)",ERR=9999) elcod,detj
        iSTOP = 1
        RETURN
      END IF
      jaci(1,1) =  jacm(2,2)/detj       !jaci(i,j) = d[xita(i)]/d[x(j)]
      jaci(1,2) = -jacm(1,2)/detj
      jaci(2,1) = -jacm(2,1)/detj
      jaci(2,2) =  jacm(1,1)/detj

!     ***  calculate cartesian derivatives

      cartd = MATMUL(deriv,jaci)       ! cartd(i,j)= d[N(i)]/d[x(j)]

      RETURN
 9999 CALL runen2('')
      END SUBROUTINE jacob3


      SUBROUTINE polINT(xa, ya, n, x, y, dy)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER,INTENT(IN) :: n
      REAL(rprec),INTENT(IN), DIMENSION(n) :: xa, ya
      REAL(rprec),INTENT(IN) :: x
      REAL(rprec),INTENT(OUT) :: y, dy
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER,PARAMETER :: nmax=10
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(rprec), DIMENSION(nmax) :: c, d
      REAL(rprec) ::  dif, dift, h0, hp, w, den
      INTEGER :: ns, i, m
!-----------------------------------------------
!      Given arrays XA and YA of length N, and given X,
!      returns Y, and an error estimate DY.
!      If P(x) is the polynomial of degree N-1 such that
!      P(AXi)=AYi, i=1,...,n, then the returned y=p(x).
!      Interpolation is done using Neville's algorithm.
!      (NUMERICAL RECIPES, p. 82).
!
       ns=1
       dif=ABS(x-xa(1))
       DO i=1,n
       dift=ABS(x-xa(i))
         IF(dift.lt.dif)then
           ns=i
           dif=dift
         ENDIF
         c(i)=ya(i)
         d(i)=ya(i)
       ENDDO
       y=ya(ns)
       ns=ns-1
       DO m=1,n-1
         DO i=1,n-m
           h0=xa(i)-x
           hp=xa(i+m)-x
           w=c(i+1)-d(i)
           den=h0-hp
           IF (den .eq. 0._dp)then
             WRITE(*,*)'Two identical xa in input'
             RETURN
           ENDIF
           den=w/den
           d(i)=hp*den
           c(i)=h0*den
         ENDDO
         IF(2*ns.lt.n-m)then
           dy=c(ns+1)
         ELSE
           dy=d(ns)
           ns=ns-1
         ENDIF
         y=y+dy
       ENDDO

      END SUBROUTINE polint


C Looking for an example. Taken from apsi.f

      SUBROUTINE COSTI (N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DIMENSION       WSAVE(*)
      PARAMETER (PI = 3.14159265358979)
      IF (N .LE. 3) THEN
      RETURN
      ENDIF
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      DT = PI/FLOAT(NM1)
c      FK = 0.D0
      KC = NP1-1
      DO 101 K=2,NS2
C         KC = NP1-K
         KC = KC - 1
C         FK = FK+1.
         FK = FLOAT(K-1)
         WSAVE(K) = 2.D0*DSIN(FK*DT)
         WSAVE(KC) = 2.D0*DCOS(FK*DT)
  101 CONTINUE
C      CALL RFFTI (NM1,WSAVE(N+1))
      RETURN
      END


	SUBROUTINE PRNLON ( np, dlon, iret )
C************************************************************************
C* PRNLON                                                               *
C*									*
C* This function converts a longitude in degrees into degrees which	*
C* fall within the range 180 to -180.					*
C*									*
C* PRNLON ( NP, DLON, IRET )						*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of longitudes		*
C*									*
C* Input and output parameters:						*
C*	DLON (NP)	REAL		Longitudes in degrees		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	11/80 						*
C* M. Goodman/RDS	 7/85	Rewritten for GEMPAK3			*
C* M. desJardins/GSFC	 1/88	Added check for missing data		*
C* K. Brill/EMC		 3/96	Add loop				*
C* M. Linda/GSC		 9/97	Changed a key word in the prologue	*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C*
	DO i = 1, np
C
C*	Check for missing data.
C
	    IF  ( .not. ERMISS ( dlon (i) ) )  THEN
        	dln   = dlon (i) - IFIX ( dlon (i) / 360. ) * 360.
		IF ( dln  .lt. -180. ) dln = dln + 360.
		IF ( dln  .gt.  180. ) dln = dln - 360.
		dlon (i) = dln
	    END IF
	END DO
C*
	RETURN
	END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_check
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks the generators for a complex rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine,
! CR and CI, and a scrictly real sine, S.
!
! To check that it is valid, a new rotation XR, XI, Y is computed. If
! |CR-XR|, |CI-XI|, |S-Y|, |NRM-1| < 3*EISCOR_DBL_EPS the generators are
! considered valid. Otherwise they are invalid.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  CR, CI          REAL(8)
!                    generators for complex cosine CR + iCI
!
!  S               REAL(8)
!                    generator for real sine S
!
! OUTPUT VARIABLES:
!
!  FLAG            LOGICAL
!                    .TRUE. implies valid generators
!                    .FALSE. implies invalid generators
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_check(CR,CI,S,FLAG)

  implicit none

  ! input variables
  real(8), intent(in) :: CR, CI, S
  logical, intent(inout) :: FLAG

  ! compute variables
  real(8), parameter :: tol = 3d0*EISCOR_DBL_EPS
  real(8) :: XR, XI, Y, NRM

  ! initialize FLAG to .FALSE.
  FLAG = .FALSE.

  ! compute new rotation from input one
  call z_rot3_vec3gen(CR,CI,S,XR,XI,Y,NRM)

  ! check for equality
  if ((abs(CR-XR)<tol).AND.(abs(CI-XI)<tol).AND.(abs(S-Y)<tol).AND.(abs(1d0-NRM)<tol)) then
    FLAG = .TRUE.
  end if

end subroutine z_rot3_check


      PROGRAM TEST
      USE FMZM
      IMPLICIT NONE

!   This function was conjectured to have all of its roots on the unit circle:

!   f(x) = (b+1)/2*x^a - b*x^(a-1) + b*x^(a-2) - ... + b*x^2 - b*x + (b+1)/2
!          a is an even integer,  b is odd.
!          For this example function, a = 110,  b = 13.

!   This program confirms that in this case, all the roots are within 1e-50 of the unit circle.

!   For subroutine ZM_ROOTS, the equation to be solved is written  F(X,NF) = 0.
!   X  is the argument to the function.
!   NF is the function number in case roots to several functions are needed.

      INTEGER :: J, KPRT, N_FOUND
      TYPE (ZM), EXTERNAL :: F
      TYPE (FM) :: ERR
      TYPE (ZM), ALLOCATABLE :: LIST_OF_ROOTS(:)

!             Set the FM precision to 50 significant digits (plus a few "guard digits").

      CALL FM_SET(50)
      CALL FM_SETVAR(" KSWIDE = 130 ")

      ALLOCATE(LIST_OF_ROOTS(110),STAT=J)
      IF (J /= 0) THEN
          WRITE (*,"(/' Error in PROGRAM ROOTS.  Unable to allocate arrays with N = ',I8/)") 110
          STOP
      ENDIF

!             Use KPRT = 1, so ZM_ROOTS will print the results.

      KPRT = 1

!             Find all roots of a 110th degree polynomial.  (NR = 110)

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Call ZM_ROOTS to find the roots of f(x) = ( 110th degree polynomial )'
      WRITE (*,*) ' '

      CALL ZM_ROOTS(110,F,1,N_FOUND,LIST_OF_ROOTS,KPRT,6)

      WRITE (*,*) ' '
      WRITE (*,*) ' Sort these roots by argument and check how close they lie to the unit circle.'
      WRITE (*,*) ' '

      CALL WRITE_ROOTS(6,N_FOUND,LIST_OF_ROOTS)

!             Check that these roots all lie on the unit circle.

      ERR = 0
      DO J = 1, N_FOUND
         ERR = MAX(ERR,ABS(1-ABS(LIST_OF_ROOTS(J))))
      ENDDO

      WRITE (*,*) ' '
      WRITE (*,"(A,ES16.7)") ' All roots lie on the unit circle within error ',TO_DP(ERR)
      WRITE (*,*) ' '

      END PROGRAM TEST

      FUNCTION F(X,NF)     RESULT (RETURN_VALUE)
      USE FMZM
      IMPLICIT NONE

!   X  is the argument to the function.
!   NF is the function number.

      INTEGER :: J, NF
      TYPE (ZM) :: RETURN_VALUE, X

      IF (NF == 1) THEN

!             (b+1)/2*x^a - b*x^(a-1) + b*x^(a-2) - ... + b*x^2 - b*x + (b+1)/2
!             a is an even integer,  b is odd.
!             For this example function, a = 110,  b = 13.
!             All the roots of this function lie on the unit circle.
!             This function has a simpler form, but is evaluated in this long form
!             to give a stronger check of roundoff control.

          RETURN_VALUE = (13+1)/2
          DO J = 2, 110
             RETURN_VALUE = RETURN_VALUE*X + (-1)**(j-1)*13
          ENDDO
          RETURN_VALUE = RETURN_VALUE*X + (13+1)/2
      ELSE IF (NF == 2) THEN
          RETURN_VALUE = SIN(X)
      ELSE
          RETURN_VALUE = X**3 - 2
      ENDIF

      END FUNCTION F

      SUBROUTINE WRITE_ROOTS(KU,N_FOUND,LIST_OF_ROOTS)
      USE FMVALS
      USE FMZM
      IMPLICIT NONE

!  Write the list of roots in order of increasing argument on unit KU.

      INTEGER :: I, J, JMIN, J_PRINTED(200), KU, KW_SAVE, N_FOUND
      TYPE (FM) :: ARG, SIZE
      TYPE (ZM) :: LIST_OF_ROOTS(N_FOUND)
      CHARACTER(50) :: STR
      DOUBLE PRECISION :: AMIN, ARGS(200)

      KW_SAVE = KW
      J_PRINTED = 0
      DO J = 1, N_FOUND
         IF (LIST_OF_ROOTS(J) == 0) THEN
             ARGS(J) = 0
         ELSE
             CALL ZM_ARG(LIST_OF_ROOTS(J),ARG)
             ARGS(J) = ARG * 180 / ACOS(-1.0D0)
             IF (ARGS(J) < 0) ARGS(J) = 360 + ARGS(J)
         ENDIF
      ENDDO

      DO I = 1, N_FOUND
         JMIN = 1
         AMIN = 420
         DO J = 1, N_FOUND
            IF (J_PRINTED(J) == 0 .AND. ARGS(J) < AMIN) THEN
                JMIN = J
                AMIN = ARGS(J)
            ENDIF
         ENDDO

         J_PRINTED(JMIN) = 1
         KW = KU
         SIZE = ABS(LIST_OF_ROOTS(JMIN))
         CALL ZM_PRINT(LIST_OF_ROOTS(JMIN))
         IF (SIZE < 1000) THEN
             WRITE (KU,"(9X,'Argument (degrees) = ',F15.10,5X,'Magnitude = ',F15.10)") AMIN,  &
                                                                                TO_DP(SIZE)
         ELSE
             CALL FM_FORM(" ES27.10 ",SIZE,STR)
             WRITE (KU,"(9X,'Argument (degrees) = ',F15.10,5X,'Magnitude = ',A)") AMIN, TRIM(STR)
         ENDIF
         WRITE (KU,*) ' '
      ENDDO

      KW = KW_SAVE

      END SUBROUTINE WRITE_ROOTS


!*==DECLINATION.spg  processed by SPAG 6.55Dc at 23:48 on  8 Aug 2008
!$author: fredfox $
!$date: 2002-09-09 16:09:16 $
!$revision: 1.3 $
!$source: /weru/cvs/weps/weps.src/util/solar/declination.for,v $

FUNCTION declination(daynum, degtorad)
IMPLICIT NONE
!*--DECLINATION9
!INCLUDE 'p1unconv.inc'
!
!*** Start of declarations rewritten by SPAG
!
! Dummy arguments
!
INTEGER :: daynum
REAL :: declination, degtorad

!
! Local variables
!
REAL :: b
!
!*** End of declarations rewritten by SPAG
!

!     + + + purpose + + +
!     this function calculates the declination of the earth with respect
!     the sun based on the day of the year

!     + + + keywords + + +
!     solar declination

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     daynum   - day of year

!     + + + local variables + + +

!     + + + local definitions + + +
!     b      - sub calculation (time of year, radians)

!     + + + common blocks + + +

!     + + + end specifications + + +

!     calculate declination angle (dec)
b = (360.0/365.0)*(daynum-81.25)*degtorad          !h-55
declination = 23.45*sin(b)                         !h-58

END FUNCTION declination


program Hermite
implicit none
integer, parameter :: real8   = selected_real_kind(13,300)
integer, parameter :: n=2
real(kind=real8), dimension(0:2*n+1,0:2*n+1)::Q
real(kind=real8), dimension(0:n):: x,f,fp
real(kind=real8), dimension(0:2*n):: z
integer i,j
open(unit=7,file='Table3.15')
read(7,*) (x(i),i=0,n)
read(7,*)  (f(i),i=0,n)
read(7,*)  (fp(i),i=0,n)
do i=0,n
  z(2*i)=x(i)
  z(2*i+1)=x(i)
  Q(2*i,0)=f(i)
  Q(2*i+1,0)=f(i)
  Q(2*i+1,1)=fp(i)
  if (i .ge. 1) then
    Q(2*i,1)=(Q(2*i,0)-Q(2*i-1,0))/(z(2*i)-z(2*i-1))
  endif
enddo
do i=2,2*n+1
  do j=2,i
    Q(i,j)=(Q(i,j-1)-Q(i-1,j-1))/(z(i)-z(i-j))
  enddo
enddo
do i=0,2*n+1
  write(*,*) i,Q(i,i)
enddo
end program Hermite


program hugeprec

use,intrinsic:: iso_fortran_env, stderr=>error_unit

implicit none (type, external)

! real128 is enabled but buggy in Gfortran 4.8. Better use Gfortran >= 5.

! shows pitfall of not being mindful with input Kind. Need to be decimal for real kinds!

! "HUGE(X) returns the largest number that is not an infinity in the type of X"

! Compare with S. 5.19, pg. 87 of "Introduction to Programming with Fortran: With Coverage of Fortran 90, 95, 2003, 2008 and 77", 3rd. Ed.,
! By Ian Chivers, Jane Sleightholme"

real(real32), parameter :: huge32 = huge(1.0_real32)
real(real64), parameter :: huge64 = huge(1.0_real64)
real(real128), parameter :: huge128 = huge(1.0_real128)
complex(real128), parameter :: ch256 = (huge128,huge128)
integer(int64), parameter :: hugeint64 = huge(1_int64)

! check 32-bit real
if (storage_size(huge32) /= 32) then
  write(stderr,*) 'expected 32-bit real but have', storage_size(huge32),'bits.'
  stop 1
endif

if (huge32 /= 3.40282347E+38) write(stderr,*) 'warning: huge32 was',huge32,'instead of 3.40282347E+38'

print *,'32-bit real Huge',huge32

! Check 64-bit real
if (storage_size(huge64) /= 64) then
  write(stderr,*) 'expected 64-bit real but have', storage_size(huge64), 'bits.'
  error stop
endif

if (huge64 /= 1.7976931348623157E+308_real64) write(stderr,*) 'warning: huge64 was ',huge64,'instead of 1.7976931348623157E+308'

print *,'64-bit real Huge',huge64

! Check 128-bit real
if (storage_size(huge128) /= 128) then
  write(stderr,*) 'expected 128-bit real but have', storage_size(huge128),'bits.'
  error stop
endif

if (huge128 /= 1.18973149535723176508575932662800702E+4932_real128) write(stderr,*) 'warning: huge128 was ',huge128,&
    'instead of 1.18973149535723176508575932662800702E+4932'

print *,'128-bit real Huge',huge128

! check 256-bit complex
if (storage_size(ch256) /= 256) then
  write(stderr,*) 'expected 256-bit complex but have', storage_size(ch256),'bits.'
  error stop
endif

if (ch256 /= (huge128,huge128)) write(stderr,*) 'warning: complex256 was ',ch256,&
    'instead of (1.18973149535723176508575932662800702E+4932,1.18973149535723176508575932662800702E+4932)'

print *,'256-bit complex huge',ch256,'consisting of',storage_size(ch256),'bits'

! Check 64-bit int
if (storage_size(hugeint64) /= 64) then
  write(stderr,*) 'expected 64-bit integer but have', storage_size(hugeint64), 'bits.'
  error stop
endif

if (hugeint64 /= 9223372036854775807_int64) write(stderr,*) 'warning: hugeint64 was ',hugeint64,'instead of 9223372036854775807'

print *,'64-bit integer Huge',hugeint64

! Must use decimal point inside Huge() or you'll get INCORRECT:
! 32-bit Huge INCORRECT   2.14748365E+09
! 64-bit Huge INCORRECT  9.2233720368547758E+018
! 128-bit Huge INCORRECT  1.70141183460469231731687303715884106E+0038

! CORRECT
! 32-bit Huge   3.40282347E+38
! 64-bit Huge   1.7976931348623157E+308
! 128-bit Huge   1.18973149535723176508575932662800702E+4932
! 64-bit Huge Integer  9223372036854775807

end program


program limits_test
    use, intrinsic :: iso_fortran_env, only : INT8, INT16, INT32, INT64, &
                                              REAL32, REAL64, REAL128
    implicit none
    integer(kind=INT8) :: i8
    integer(kind=INT16) :: i16
    integer(kind=INT32) :: i32
    integer(kind=INT64) :: i64
    real(kind=REAL32) :: x32
    real(kind=REAL64) :: x64
    real(kind=REAL128) :: x128

    print '(A)', 'integer:'

    print '(2X, A)', 'huge'
    print *, kind(i8), huge(i8)
    print *, kind(i16), huge(i16)
    print *, kind(i32), huge(i32)
    print *, kind(i64), huge(i64)

    print '(2X, A)', '(binary) digits'
    print *, kind(i8), digits(i8)
    print *, kind(i16), digits(i16)
    print *, kind(i32), digits(i32)
    print *, kind(i64), digits(i64)

    print '(2X, A)', 'range'
    print *, kind(i8), range(i8)
    print *, kind(i16), range(i16)
    print *, kind(i32), range(i32)
    print *, kind(i64), range(i64)

    print '(A)', 'real:'

    print '(2X, A)', 'huge:'
    print *, kind(x32), huge(x32)
    print *, kind(x64), huge(x64)
    print *, kind(x128), huge(x128)

    print '(2X, A)', 'tiny:'
    print *, kind(x32), tiny(x32)
    print *, kind(x64), tiny(x64)
    print *, kind(x128), tiny(x128)

    print '(2X, A)', 'epsilon:'
    print *, kind(x32), epsilon(x32)
    print *, kind(x64), epsilon(x64)
    print *, kind(x128), epsilon(x128)

    print '(2X, A)', 'range:'
    print *, kind(x32), range(x32)
    print *, kind(x64), range(x64)
    print *, kind(x128), range(x128)

    print '(2X, A)', 'minexponent:'
    print *, kind(x32), minexponent(x32)
    print *, kind(x64), minexponent(x64)
    print *, kind(x128), minexponent(x128)

    print '(2X, A)', 'maxexponent:'
    print *, kind(x32), maxexponent(x32)
    print *, kind(x64), maxexponent(x64)
    print *, kind(x128), maxexponent(x128)

    print '(2X, A)', 'precision:'
    print *, kind(x32), precision(x32)
    print *, kind(x64), precision(x64)
    print *, kind(x128), precision(x128)

    print '(2X, A)', '(binary) digits:'
    print *, kind(x32), digits(x32)
    print *, kind(x64), digits(x64)
    print *, kind(x128), digits(x128)

end program limits_test


MODULE generic_procedure_module
!
!  Purpose:
!    To define the derived data type for 2D vectors,
!    plus two generic bound procedures.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     12/27/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare type vector
TYPE :: vector
   REAL :: x                         ! X value
   REAL :: y                         ! Y value
CONTAINS
   GENERIC :: add => vector_plus_vector, vector_plus_scalar
   PROCEDURE,PASS :: vector_plus_vector
   PROCEDURE,PASS :: vector_plus_scalar
END TYPE vector

! Add procedures
CONTAINS

   TYPE (vector) FUNCTION vector_plus_vector ( this, v2 )
   !
   !  Purpose:
   !    To add two vectors.
   !
   !  Record of revisions:
   !       Date       Programmer          Description of change
   !       ====       ==========          =====================
   !     12/27/06    S. J. Chapman        Original code
   !
   IMPLICIT NONE

   ! Data dictionary: declare calling parameter types & definitions
   CLASS(vector),INTENT(IN) :: this         ! First vector
   CLASS(vector),INTENT(IN) :: v2           ! Second vector

   ! Add the vectors
   vector_plus_vector%x = this%x + v2%x
   vector_plus_vector%y = this%y + v2%y

   END FUNCTION vector_plus_vector

   TYPE (vector) FUNCTION vector_plus_scalar ( this, s )
   !
   !  Purpose:
   !    To add a vector and a scalar.
   !
   !  Record of revisions:
   !       Date       Programmer          Description of change
   !       ====       ==========          =====================
   !     12/27/06    S. J. Chapman        Original code
   !
   IMPLICIT NONE

   ! Data dictionary: declare calling parameter types & definitions
   CLASS(vector),INTENT(IN) :: this         ! First vector
   REAL,INTENT(IN) :: s                     ! Scalar

   ! Add the points
   vector_plus_scalar%x = this%x + s
   vector_plus_scalar%y = this%y + s

   END FUNCTION vector_plus_scalar

END MODULE generic_procedure_module


      SUBROUTINE RZDCAL(AMAT,IH,IK,IL,R0,Z0,D0)
      IMPLICIT NONE
C
      REAL AMAT(3,3)
      REAL R0,Z0,D0
      INTEGER IH,IK,IL
C
      INTEGER I,J
      DOUBLE PRECISION RC(3),H(3)
      DOUBLE PRECISION ZZ,DD
C
      H(1) = DBLE(IH)
      H(2) = DBLE(IK)
      H(3) = DBLE(IL)
C
      DD = 0.0D0
      DO 20 I=1,3
         RC(I) = 0.0D0
         DO 10 J=1,3
            RC(I) = RC(I) + DBLE(AMAT(I,J))*H(J)
 10      CONTINUE
         DD = DD + RC(I)**2
 20   CONTINUE
      ZZ = ABS(RC(3)**2)
      IF(DD.GT.ZZ)THEN
         R0 = SNGL(SQRT(DD-ZZ))
      ELSE
         R0 = 0.0
      ENDIF
      Z0 = SNGL(SQRT(ZZ))
      D0 = SNGL(SQRT(DD))
      RETURN
C
      END


      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


module funclib

  !--------------------------------------------------------------------!
  !      a library with implementations of mathemetical functions      !
  !                                                                    !
  ! currently implemented:                                             !
  !                                                                    !
  ! P_lgndr  -  associated Legendre polynomial                         !
  !                                                                    !
  !--------------------------------------------------------------------!
  ! 2010-11-03 Alexander Urban                                         !
  !--------------------------------------------------------------------!

  implicit none

  double precision, parameter :: EPS   = epsilon(1.0d0)
  double precision, parameter :: FPMIN = tiny(1.0d0)
  double precision, parameter :: FPMAX = huge(1.0d0)

contains

  !--------------------------------------------------------------------!
  !                  associated Legendre polynomials                   !
  !                                                                    !
  !     plgndr - (C) Copr. 1986-92 Numerical Recipes Software ,4-#     !
  !                   (modified by Alexander Urban)                    !
  !--------------------------------------------------------------------!

  function P_lgndr(l,m,x) result(P_lm)

    implicit none

    integer,          intent(in) :: l, m
    double precision, intent(in) :: x
    double precision             :: P_lm
    integer                      :: i, ll
    double precision             :: fact, pll, pmm, pmmp1, somx2

    if ( (m < 0) .or. (m > l) .or. (abs(x) > 1.0d0) ) then
       write(0,*) 'Error: invalid parameters in P_lgndr'
       stop
    end if

    pmm = 1.0d0

    if ( m > 0 ) then
       somx2 = sqrt((1.0d0-x)*(1.0d0+x))
       fact  = 1.0d0
       do i = 1, m
          pmm  = -pmm*fact*somx2
          fact = fact+2.
       end do
    end if

    if ( l == m ) then
       P_lm = pmm
    else
       pmmp1 = x*(2*m + 1)*pmm
       if ( l == (m+1) ) then
          P_lm = pmmp1
       else
          pll = 0.0d0
          do ll = m+2, l
             pll   = (x*(2*ll - 1)*pmmp1 - (ll + m - 1)*pmm)/(ll - m)
             pmm   = pmmp1
             pmmp1 = pll
          end do
          P_lm = pll
       end if
    end if

  end function P_lgndr

  !--------------------------------------------------------------------!
  !                           gamma function                           !
  !                                                                    !
  ! G(z) = int_0^\infty { t^{z - 1} e^{-t} dt }                        !
  !                                                                    !
  ! G(z) becomes large very quickly, therefore gammln(z) returns the   !
  ! logarithm ln(G(z)).                                                !
  !                                                                    !
  ! adapted from: Press, et al. Numerical Recipes in F77, 1986-92      !
  !                                                                    !
  !--------------------------------------------------------------------!

  function gammln(xx) result(gln)

    implicit none

    double precision, intent(in)  :: xx
    double precision              :: gln

    double precision,               parameter :: stp = 2.5066282746310005d0
    double precision, dimension(6), parameter :: cof = &
    (/ 76.18009172947146d0, -86.50532032941677d0,    24.01409824083091d0, &
       -1.231739572450155d0,  0.1208650973866179d-2, -0.5395239384953d-5 /)

    integer          :: j
    double precision :: ser, tmp, x, y

    x   = xx
    y   = x
    tmp = x + 5.5d0
    tmp = (x + 0.5d0)*log(tmp) - tmp
    ser = 1.000000000190015d0
    do j = 1, 6
       y   = y + 1.d0
       ser = ser + cof(j)/y
    end do
    gln = tmp + log(stp*ser/x)

  end function gammln

  !--------------------------------------------------------------------!
  !                     incomplete gamma functions                     !
  !                                                                    !
  ! gammap - P(a,x) = 1/gamma(a) int_0^x { e^{it} t^{a-1} dt } (a > 0) !
  ! gammaq - Q(a,x) = 1 - P(a,x)                                       !
  !                                                                    !
  ! adapted from: Press, et al. Numerical Recipes in F77, 1986-92      !
  !                                                                    !
  !--------------------------------------------------------------------!

  function gamma_P(a,x) result(P)

    implicit none

    ! NR name: gammp

    double precision, intent(in) :: a, x
    double precision             :: P
    double precision             :: gammcf, gamser, gln

    if ((x < 0.0d0) .or. (a <= 0.0d0)) then
       write(0,*) "Error: bad arguments in `gamma_P()'."
       P = 0.0d0
       return
    end if

    if (x < a + 1.0d0) then
       call gamma_series(gamser,a,x,gln)
       P = gamser
    else
       call gamma_cf(gammcf,a,x,gln)
       P = 1.0d0 - gammcf
    endif

  end function gamma_P

  !--------------------------------------------------------------------!

  function gamma_Q(a,x) result(Q)

    implicit none

    ! NR name: gammq()

    double precision, intent(in) :: a, x
    double precision             :: Q
    double precision             :: gammcf, gamser, gln

    if ((x < 0.0d0) .or. (a <= 0.0d0)) then
       write(0,*) "Error: bad arguments in `gamma_Q()'."
       Q = 0.0d0
       return
    end if

    if (x < a + 1.0d0) then
       call gamma_series(gamser,a,x,gln)
       Q = 1.0d0 - gamser
    else
       call gamma_cf(gammcf,a,x,gln)
       Q = gammcf
    endif

  end function gamma_Q

  !--------------------------------------------------------------------!

  subroutine gamma_series(gamser, a, x, gln)

    implicit none

    ! NR name: gser()

    double precision, intent(in)  :: a, x
    double precision, intent(out) :: gamser, gln

    integer,            parameter :: ITMAX = 1000
    integer                       :: n
    double precision              :: ap, del, gsum

    gln = gammln(a)

    if (x <= 0.0d0) then
       if (x < 0.0d0) then
          write(0,*) "Error: x < 0 in `gamma_series()'"
       end if
       gamser = 0.0d0
       return
    endif

    ap  = a
    gsum = 1.0d0/a
    del = gsum

    n = 1
    do
       ap  = ap + 1.0d0
       del = del*x/ap
       gsum = gsum + del
       if (abs(del) < abs(gsum)*EPS) exit
       n = n + 1
       if (n > ITMAX) then
          write(0,*) "Warning: a too large, ITMAX too small in `gamma_series()'"
          exit
       end if
    end do

    gamser = gsum*exp(-x + a*log(x) - gln)

  end subroutine gamma_series

  !--------------------------------------------------------------------!

  subroutine gamma_cf(gammcf, a, x, gln)

    implicit none

    ! NR name: gcf()

    double precision, intent(in)  :: a, x
    double precision, intent(out) :: gammcf, gln

    integer,            parameter :: ITMAX = 1000
    integer                       :: i
    double precision              :: an, b, c, d, del, h

    gln = gammln(a)
    b   = x + 1.0d0 - a
    c   = 1.0d0/FPMIN
    d   = 1.0d0/b
    h   = d

    i = 1
    do
       an  = -dble(i)*(dble(i) - a)
       b   = b + 2.0d0
       d   = an*d + b
       if (abs(d) < FPMIN) d = FPMIN
       c   = b + an/c
       if (abs(c) < FPMIN) c = FPMIN
       d   = 1.0d0/d
       del = d*c
       h   = h*del
       if (abs(del - 1.0d0) < EPS) exit
       i = i + 1
       if (i > ITMAX) then
          write(0,*) "Warning: a too large, ITMAX too small in `gamma_cf()'"
          exit
       end if
    end do

    gammcf = exp(-x + a*log(x) - gln)*h

  end subroutine gamma_cf

  !--------------------------------------------------------------------!
  !          error function and complementary error function           !
  !                                                                    !
  ! erf(x)  = 2/sqrt(pi) int_0^x { e^{-t^2} dt }                       !
  ! erfc(x) = 1 - erf(x) = 2/sqrt(pi) int_0^\infty { e^{-t^2} dt }     !
  !                                                                    !
  ! relation to the incomplete gamma functions (see above):            !
  !                                                                    !
  !   erf(x)  = P(1/2, x^2) ;  (x >= 0)                                !
  !   erfc(x) = Q(1/2, x^2) ;  (x >= 0)                                !
  !                                                                    !
  ! adapted from: Press, et al. Numerical Recipes in F77, 1986-92      !
  !                                                                    !
  !--------------------------------------------------------------------!

  function erf(x) result(y)

    implicit none

    double precision, intent(in) :: x
    double precision             :: y

    if (x < 0.0d0) then
       y = -gamma_P(0.5d0, x*x)
    else
       y =  gamma_P(0.5d0, x*x)
    endif

  end function erf

  !--------------------------------------------------------------------!

  function erfc(x) result(y)

    implicit none

    double precision, intent(in) :: x
    double precision             :: y

    if (x < 0.0d0) then
       y = 1.0d0 + gamma_P(0.5d0, x*x)
    else
       y = gamma_Q(0.5d0, x*x)
    endif

  end function erfc

end module funclib


      REAL J(0:50)

100   PRINT *, ' Enter maximum value of n (.le. 50; .lt. 0 to stop)'
      READ *, NMAX
      IF (NMAX .LT. 0) STOP
      IF (NMAX .GT. 50) NMAX=50
      PRINT *,' Enter value of x'
      READ *,X

      J(NMAX)=0.
      J(NMAX-1)=1.E-20
      DO 10 N=NMAX-1,1,-1
         J(N-1)=(2*N/X)*J(N)-J(N+1)
10    CONTINUE

      SUM=J(O)
      DO 20 N=2,NMAX,2
          SUM=SUM+2*J(N)
20    CONTINUE

      DO 30 N=0,NMAX
         J(N)=J(N)/SUM
         PRINT *,N,J(N)
30    CONTINUE

      GOTO 100
      END


      subroutine DHFTI (A,LDA,M1,N1,B,LDB,KB,TAU,KRANK,RNORM,WORK,IP)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2006-03-20 DHFTI Krogh  Changed LDB to LDA in an error message.
c>> 1996-03-30 DHFTI Krogh  Added external statement.
C>> 1994-10-20 DHFTI Krogh  Changes to use M77CON
C>> 1994-04-20 DHFTI CLL Edited to make DP & SP files similar.
c>> 1993-02-09 CLL.  Fixed index in 1st reference to [D/S]NRM2.
C>> 1992-03-13 DHFTI  FTK  Removed implicit statements.
C>> 1987-11-24 DHFTI  Lawson  Initial code.
c--D replaces "?": ?HFTI, ?HTCC, ?HTGEN, ?DOT, ?NRM2
c
c     ------------------------------------------------------------------
c          This subr solves the least squares problem
c
c                          A * X  ~=~  B
c
c     where A is a given M x N matrix, B is a given M x KB matrix and
c     X is the N x KB solution matrix to be determined.  This includes
c     the usual special case of KB = 1 where B is an M-vector and the
c     solution, X, is an N-vector.
c
c          This subr permits M > N, M = N, or M < N.  This subr
c     determines the "pseudorank", i.e. the estimated rank, of A based
c     on a user-provided tolerance.  If the pseudorank is less than N,
c     the minimal length solution, i.e. the pseudoinverse solution, to
c     the problem is computed.
c
c          Note that this subr can be used to compute the pseudoinverse
c     of a matrix, A.  Set B to the M x M identity matrix and the
c     solution matrix, X, will be the pseudoinverse of A.
c
c          The algorithm is HFTI from the L & H book.  This method does
c     a Householder QR decomposition from the left.  Then if the
c     pseudorank is less than N it does a second Householder QR
c     decomposition from the right.
c
c          The results returned in A(,), RNORM(), and IP() can be used
c     by subroutine SCOV1 or DCOV1 to compute the covariance matrix of
c     the solution vectors.
c     ------------------------------------------------------------------
c                     SUBROUTINE ARGUMENTS
c
c     A(,)     (In/Out)  On input, contains the M x N matrix, A.  Permit
c              M > N, M = N, or M < N.  On return A(,) will contain an
c              upper triangular matrix of order KRANK that can be used
c              by subr _COV2 to compute a covariance matrix when
c              KRANK = N.
c
c     LDA      (In)  The first dimension of the array A(,).
c              Require LDA .ge. M.
c
c     M        (In)  No. of rows of matrices A and B.  Require M .ge. 1.
c
c     N        (In)  No. of columns of matrix A, and rows of matrix X.
c              Require N .ge. 0.
c
c     B(,)     (In/Out)  If KB > 0, the array B(,) must initially
c              contain the right-side matrix, B, having M rows and KB
c              columns.  On return the array B(,) will contain the
c              N x KB solution matrix X.
c              If KB = 0, this subr will not reference the array B(,).
c
c     LDB      (In)  First dimensioning parameter for the array B(,).
c              If KB > 0, require LDB .ge. Max( M, N).
c              If KB = 0, require LDB .ge. 1.
c
c     KB       (In)  No. of columns of the matrices B and X.
c              Require KB .ge. 0.
c              If KB = 0, this subr will not reference the array B(,).
c
c     TAU      (In)  Absolute tolerance parameter provided by user for
c              pseudorank determination.
c
c     KRANK    (Out)  Set by subr to indicate the pseudorank of A.
c              This means that the first KRANK diagonal elements in the
c              the upper triangular factor matrix derived from A each
c              exceed TAU in magnitude.  Either KRANK = Min( M, N), or
c              the the magnitude of the diagonal element in position
c              KRANK + 1 is less than or equal to TAU.
c
c     RNORM()  (Out)  On return, RNORM(J) will contain the euclidean
c              norm of the residual vector for the problem defined by
c              the Jth column vector of the input matrix, B, for
c              J = 1, ..., KB.
c
c     WORK()  (Scratch)  Array used for work space by this subr.
c             Must be of length at least N.
c
c     IP()    (Work/Out)  Integer array of length at least N in which
c              the subr will store column permutation information.
c     -----------------------------------------------------------------
c     Subprograms referenced directly: ERMSG, ERMOR, IERM1, IERV1
c          D1MACH, DHTCC, DHTGEN, DDOT, DNRM2
c     Other subprograms needed: ERFIN
c     -----------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb 1985, Mar 1987, June 1987.  C. L. Lawson & S. Y. Chiu, JPL.
c     Adapted code from the Lawson & Hanson book to Fortran 77 for use
c     in the JPL MATH77 library.
c     Changed code to provide oveflow avoidance.
c     Replaced previous scratch arrays H() and G() by WORK().
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     ------------------------------------------------------------------
c     1983 Sept 22. CLL added computation of RNORM() for the
c     exceptional case of N = 0.
c     -----------------------------------------------------------------
      EXTERNAL D1MACH, DDOT, DNRM2
      INTEGER LDA,M1,N1,LDB,KB,KRANK,IP(N1)
      INTEGER I,II,J,JB,K,KP1,L,LDIAG,LMAX,M,N,NTERMS
      DOUBLE PRECISION D1MACH,DDOT,DNRM2
      DOUBLE PRECISION A(LDA,N1),B(LDB,*),FACTOR,HFAC,ONE
      DOUBLE PRECISION RNORM(KB),SM1,SMALL,TAU,TMP,UPARAM,WORK(N1),ZERO
      logical COMSQR, COL, ROW
      parameter(ONE = 1.0D0, ZERO=0.0D0, FACTOR = 1000.0D0)
      parameter(COL = .true., ROW = .false.)
c     -----------------------------------------------------------------
C
      M = M1
      N = N1
      if( M .lt. 1 .or. N .lt. 0 .or. KB .lt. 0 .or. LDA .lt. M ) then
         call ERMSG('DHFTI',1,0,
     *   'Bad argument values.  Require M .ge. 1, N .ge. 0,', ',')
         call ERMOR('KB .ge. 0, and LDA .ge. M', ',')
         call IERV1('M',  M,   ',')
         call IERV1('N',  N,   ',')
         call IERV1('KB',  KB,   ',')
         call IERV1('LDA',LDA, '.')
         KRANK = 0
         return
      elseif( KB .eq. 0) then
         if(LDB .le. 0) then
            call IERM1('DHFTI',2,0,
     *         'Require LDB .ge. 1 when KB .eq. 0', 'LDB', LDB, '.')
            KRANK = 0
            return
         endif
      elseif(LDB .lt. max(M,N)) then
         call IERM1('DHFTI',3,0,
     *      'Require LDB .ge. max(M,N) when KB .ge. 1', 'KB',  KB, ',')
         call IERV1('LDB',LDB, '.')
         KRANK = 0
         return
      endif
c
      if (N .eq. 0) then
         do 10 J = 1, KB
            RNORM(J) = DNRM2(M, B(1,J), 1)
  10     continue
         KRANK = 0
         return
      endif
c                                 Here we have M > 0 and N > 0.
      SMALL = FACTOR * D1MACH(4)
      LDIAG = MIN(M,N)
C
      DO 80 J = 1,LDIAG
       if(J .eq. N) then
c      - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c           Special for J = N.  This case is much simpler than J < N
c           since there are no more columns of A beyond the jth to be
c           considered for interchange or to be triangularized.
c
         IP(N) = N
         CALL DHTCC (1,N,N+1,M,A(1,N),UPARAM,B,LDB,KB)
c      - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
       else
c      - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                                   Here we have J < N.
         IF (J .EQ. 1) THEN
            COMSQR = .TRUE.
         ELSE
c                  Update scaled squared column lengths and set LMAX.
c
            LMAX = J
            DO 20 L = J,N
               WORK(L) = WORK(L) - (HFAC * A(J-1,L))**2
               IF (WORK(L) .GT. WORK(LMAX)) LMAX = L
   20       continue
            COMSQR =  WORK(LMAX) .LE. SMALL
         ENDIF
C
         IF( COMSQR ) THEN
C
C              Compute scaled squared column lengths and set LMAX.
c              Scaling using HFAC protects against overflow of squared
c              numbers.
c
            NTERMS = M - J + 1
            LMAX = J
            DO 40 L = J,N
               WORK(L) = DNRM2(NTERMS, A(J,L), 1)
               IF (WORK(L) .GT. WORK(LMAX)) LMAX = L
   40       continue
            if(WORK(LMAX) .eq. ZERO) then
               HFAC = ONE
            else
               HFAC = ONE/WORK(LMAX)
            endif
            do 45 L = J,N
               WORK(L) = (HFAC * WORK(L))**2
   45       continue
         ENDIF
C
C                               DO COLUMN INTERCHANGES IF NEEDED.
C
         IP(J) = LMAX
         IF (IP(J) .NE. J) THEN
            DO 60 I = 1,M
               TMP = A(I,J)
               A(I,J) = A(I,LMAX)
   60          A(I,LMAX) = TMP
            WORK(LMAX) = WORK(J)
         ENDIF
C
C          Compute the J-th transformation and apply it to A and B.
C          Since we treated J = N as a special case we here have J < N
c          so the reference to A(1,J+1) is valid.
c
         CALL DHTCC (1,J,J+1,M,A(1,J),UPARAM,A(1,J+1),LDA,N-J)
         CALL DHTCC (2,J,J+1,M,A(1,J),UPARAM,B,LDB,KB)
c      - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
       endif
   80 continue
C
C              DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C
      K = LDIAG
      DO 90 J = 1,LDIAG
         IF (ABS(A(J,J)).LE.TAU) THEN
            K = J - 1
            GO TO 100
         ENDIF
   90 continue
  100 continue
      KP1 = K + 1
C
C                         COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
      DO 130 JB = 1,KB
         TMP = ZERO
         DO 120 I = KP1,M
  120       TMP = TMP + B(I,JB)**2
         RNORM(JB) = SQRT(TMP)
  130 continue
C                          Special termination when Pseudorank = 0
      IF (K .EQ. 0) THEN
         DO 155 JB = 1,KB
            DO 150 I = 1,N
              B(I,JB) = ZERO
  150       continue
  155    continue
         KRANK = 0
         RETURN
      ENDIF
C
C               IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C               DECOMPOSITION OF FIRST K ROWS.
C
      IF (K .NE. N) THEN
         DO 170 II = 1,K
            I = KP1-II
            CALL DHTGEN(1,I,KP1,N,A(I,1),LDA,ROW,WORK(I),A,LDA,I-1,ROW)
  170    continue
      ENDIF
C
      DO 260 JB = 1,KB
C
C                        SOLVE THE K BY K TRIANGULAR SYSTEM.
C
         DO 210 L = 1,K
            I = KP1 - L
            IF (I .LT. K) THEN
               SM1 = DDOT(K-I,A(I,I+1),LDA,B(I+1,JB),1)
            ELSE
               SM1 = ZERO
            END IF
            B(I,JB) = (B(I,JB)-SM1) / A(I,I)
  210    continue
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
         IF (K .NE. N) THEN
            DO 220 J = KP1,N
  220          B(J,JB) = ZERO
            DO 230 I = 1,K
  230          CALL DHTGEN(2,I,KP1,N,A(I,1),LDA,ROW,WORK(I),
     *                    B(1,JB),LDB,1,COL)
         ENDIF
C                    RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C                    COLUMN INTERCHANGES.
C
         DO 250 J = LDIAG, 1, -1
            IF (IP(J) .NE. J) THEN
               L = IP(J)
               TMP = B(L,JB)
               B(L,JB) = B(J,JB)
               B(J,JB) = TMP
            ENDIF
  250    continue
  260 continue
      KRANK = K
      return
      end


function c4_normal_01 ( seed )

!*****************************************************************************80
!
!! C4_NORMAL_01 returns a unit pseudonormal C4.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, complex ( kind = 4 ) C4_NORMAL_01, a unit pseudonormal value.
!
  implicit none

  complex ( kind = 4 ) c4_normal_01
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 4 ) v1
  real ( kind = 4 ) v2
  real ( kind = 4 ) x_c
  real ( kind = 4 ) x_r

  v1 = r4_uniform_01 ( seed )
  v2 = r4_uniform_01 ( seed )

  x_r = sqrt ( - 2.0E+00 * log ( v1 ) ) * cos ( 2.0E+00 * r4_pi * v2 )
  x_c = sqrt ( - 2.0E+00 * log ( v1 ) ) * sin ( 2.0E+00 * r4_pi * v2 )

  c4_normal_01 = cmplx ( x_r, x_c )

  return
end
function c8_normal_01 ( seed )

!*****************************************************************************80
!
!! C8_NORMAL_01 returns a unit pseudonormal C8.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) SEED, a seed for the random number
!    generator.
!
!    Output, complex ( kind = 8 ) C8_NORMAL_01, a sample of the PDF.
!
!    Output, integer ( kind = 4 ) SEED, a seed for the random number
!    generator.
!
  implicit none

  complex ( kind = 8 ) c8_normal_01
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) v1
  real ( kind = 8 ) v2
  real ( kind = 8 ) x_c
  real ( kind = 8 ) x_r

  v1 = r8_uniform_01 ( seed )
  v2 = r8_uniform_01 ( seed )

  x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * r8_pi * v2 )
  x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * r8_pi * v2 )

  c8_normal_01 = cmplx ( x_r, x_c, kind = 8 )

  return
end
function i4_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! I4_NORMAL_AB returns a scaled pseudonormal I4.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!    The result is then rounded to the nearest integer.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 4 ) A, the mean of the PDF.
!
!    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the
!    random number generator.
!
!    Output, integer ( kind = 4 ) I4_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  integer ( kind = 4 ) i4_normal_ab
  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  i4_normal_ab = nint ( a + b * x )

  return
end
function i8_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! I8_NORMAL_AB returns a scaled pseudonormal I8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!    The result is then rounded to the nearest integer.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, the mean of the PDF.
!
!    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the
!    random number generator.
!
!    Output, integer ( kind = 8 ) I8_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 8 ) i8_normal_ab
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  i8_normal_ab = nint ( a + b * x )

  return
end
function r4_normal_01 ( seed )

!*****************************************************************************80
!
!! R4_NORMAL_01 returns a unit pseudonormal R4.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) R4_NORMAL_01, a sample of the standard
!    normal PDF.
!
  implicit none

  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ) r4_normal_01
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  r4_normal_01 = x

  return
end
function r4_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! R4_NORMAL_AB returns a scaled pseudonormal R4.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 4 ) A, the mean of the PDF.
!
!    Input, real ( kind = 4 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) R4_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  real ( kind = 4 ) r1
  real ( kind = 4 ) r2
  real ( kind = 4 ) r4_normal_ab
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x

  r1 = r4_uniform_01 ( seed )
  r2 = r4_uniform_01 ( seed )
  x = sqrt ( - 2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * r4_pi * r2 )

  r4_normal_ab = a + b * x

  return
end
function r4_uniform_01 ( seed )

!*****************************************************************************80
!
!! R4_UNIFORM_01 returns a unit pseudorandom R4.
!
!  Discussion:
!
!    An R4 is a real ( kind = 4 ) value.
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r4_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R4_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 4 ) R4_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 4 ) r4_uniform_01

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + i4_huge
  end if

  r4_uniform_01 = real ( seed, kind = 4 ) * 4.656612875E-10

  return
end
subroutine r4vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R4VEC_UNIFORM_01 returns a unit pseudorandom R4VEC.
!
!  Discussion:
!
!    An R4VEC is an array of real ( kind = 4 ) values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, Number 2, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value,
!    which should NOT be 0.
!    On output, SEED has been updated.
!
!    Output, real ( kind = 4 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_huge = 2147483647
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 4 ) r(n)

  if ( seed == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'R4VEC_UNIFORM_01 - Fatal error!'
    write ( *, '(a)' ) '  Input value of SEED = 0.'
    stop 1
  end if

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + i4_huge
    end if

    r(i) = real ( seed, kind = 4 ) * 4.656612875E-10

  end do

  return
end
subroutine r4vec_normal_ab ( n, a, b, seed, x )

!*****************************************************************************80
!
!! R4VEC_NORMAL_AB returns a scaled pseudonormal R4VEC.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!    An R4VEC is a vector of R4's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input, real ( kind = 4 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 4 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 4 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 4 ) a
  real ( kind = 4 ) b
  integer ( kind = 4 ) m
  real ( kind = 4 ) r(n+1)
  real ( kind = 4 ), parameter :: r4_pi = 3.141592653589793E+00
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 4 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r4_uniform_01 ( seed )

    if ( r(1) == 0.0E+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R4VEC_NORMAL_AB - Fatal error!'
      write ( *, '(a)' ) '  R4_UNIFORM_01 returned a value of 0.'
      stop 1
    end if

    r(2) = r4_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0E+00 * log ( r(1) ) ) * cos ( 2.0E+00 * r4_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r4vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0E+00 * r4_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r4vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0E+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0E+00 * r4_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0E+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0E+00 * r4_pi * r(2*m) )

  end if

  x(1:n) = a + b * x(1:n)

  return
end
function r8_normal_01 ( seed )

!*****************************************************************************80
!
!! R8_NORMAL_01 returns a unit pseudonormal R8.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed
!    random value.
!
  implicit none

  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_01
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_01 = x

  return
end
function r8_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! R8_NORMAL_AB returns a scaled pseudonormal R8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real ( kind = 8 ) A, the mean of the PDF.
!
!    Input, real ( kind = 8 ) B, the standard deviation of the PDF.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) R8_NORMAL_AB, a sample of the normal PDF.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_ab
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_ab = a + b * x

  return
end
function r8_uniform_01 ( seed )

!*****************************************************************************80
!
!! R8_UNIFORM_01 returns a unit pseudorandom R8.
!
!  Discussion:
!
!    This routine implements the recursion
!
!      seed = 16807 * seed mod ( 2^31 - 1 )
!      r8_uniform_01 = seed / ( 2^31 - 1 )
!
!    The integer arithmetic never requires more than 32 bits,
!    including a sign bit.
!
!    If the initial seed is 12345, then the first three computations are
!
!      Input     Output      R8_UNIFORM_01
!      SEED      SEED
!
!         12345   207482415  0.096616
!     207482415  1790989824  0.833995
!    1790989824  2035175616  0.947702
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.
!    On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate,
!    strictly between 0 and 1.
!
  implicit none

  integer ( kind = 8 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + 2147483647
  end if
!
!  Although SEED can be represented exactly as a 32 bit integer,
!  it generally cannot be represented exactly as a 32 bit real number!
!
  r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end
subroutine r8mat_normal_01 ( m, n, seed, r )

!*****************************************************************************80
!
!! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 November 2010
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  call r8vec_normal_01 ( m * n, seed, r )

  return
end
subroutine r8mat_normal_ab ( m, n, a, b, seed, r )

!*****************************************************************************80
!
!! R8MAT_NORMAL_AB returns a scaled pseudonormal R8MAT.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns
!    in the array.
!
!    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(m,n)

  call r8vec_normal_ab ( m * n, a, b, seed, r )

  return
end
subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows in A.
!
!    Input, integer ( kind = 4 ) N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 September 2009
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ), parameter :: incx = 5
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i2hi
  integer ( kind = 4 ) i2lo
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) inc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j2hi
  integer ( kind = 4 ) j2lo
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  if ( m <= 0 .or. n <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  (None)'
    return
  end if

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end
subroutine r8vec_normal_01 ( n, seed, x )

!*****************************************************************************80
!
!! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
!
!  Discussion:
!
!    An R8VEC is an array of double precision real values.
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2014
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) m
  real ( kind = 8 ) r(n+1)
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r8_uniform_01 ( seed )

    if ( r(1) == 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!'
      write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
      stop 1
    end if

    r(2) = r8_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2*m) )

  end if

  return
end
subroutine r8vec_normal_ab ( n, a, b, seed, x )

!*****************************************************************************80
!
!! R8VEC_NORMAL_AB returns a scaled pseudonormal R8VEC.
!
!  Discussion:
!
!    The standard normal probability distribution function (PDF) has
!    mean 0 and standard deviation 1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    06 August 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values desired.
!
!    Input, real ( kind = 8 ) A, B, the mean and standard deviation.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random
!    number generator.
!
!    Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) R(N+1), is used to store some uniform
!    random values.  Its dimension is N+1, but really it is only needed
!    to be the smallest even number greater than or equal to N.
!
!    Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range
!    of entries of X that we need to compute.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  integer ( kind = 4 ) m
  real ( kind = 8 ) r(n+1)
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x(n)
  integer ( kind = 4 ) x_hi_index
  integer ( kind = 4 ) x_lo_index
!
!  Record the range of X we need to fill in.
!
  x_lo_index = 1
  x_hi_index = n
!
!  If we need just one new value, do that here to avoid null arrays.
!
  if ( x_hi_index - x_lo_index + 1 == 1 ) then

    r(1) = r8_uniform_01 ( seed )

    if ( r(1) == 0.0D+00 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'R8VEC_NORMAL_AB - Fatal error!'
      write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
      stop 1
    end if

    r(2) = r8_uniform_01 ( seed )

    x(x_hi_index) = &
      sqrt ( - 2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * r8_pi * r(2) )
!
!  If we require an even number of values, that's easy.
!
  else if ( mod ( x_hi_index - x_lo_index, 2 ) == 1 ) then

    m = ( x_hi_index - x_lo_index + 1 ) / 2

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-1:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m:2) )
!
!  If we require an odd number of values, we generate an even number,
!  and handle the last pair specially, storing one in X(N), and
!  saving the other for later.
!
  else

    x_hi_index = x_hi_index - 1

    m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1

    call r8vec_uniform_01 ( 2*m, seed, r )

    x(x_lo_index:x_hi_index-1:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(x_lo_index+1:x_hi_index:2) = &
      sqrt ( - 2.0D+00 * log ( r(1:2*m-3:2) ) ) &
      * sin ( 2.0D+00 * r8_pi * r(2:2*m-2:2) )

    x(n) = sqrt ( - 2.0D+00 * log ( r(2*m-1) ) ) &
      * cos ( 2.0D+00 * r8_pi * r(2*m) )

  end if

  x(1:n) = a + b * x(1:n)

  return
end
subroutine r8vec_print ( n, a, title )

!*****************************************************************************80
!
!! R8VEC_PRINT prints an R8VEC.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    22 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of components of the vector.
!
!    Input, real ( kind = 8 ) A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  integer ( kind = 4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '

  do i = 1, n
    write ( *, '(2x,i8,a,1x,g16.8)' ) i, ':', a(i)
  end do

  return
end
subroutine r8vec_uniform_01 ( n, seed, r )

!*****************************************************************************80
!
!! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Paul Bratley, Bennett Fox, Linus Schrage,
!    A Guide to Simulation,
!    Second Edition,
!    Springer, 1987,
!    ISBN: 0387964673,
!    LC: QA76.9.C65.B73.
!
!    Bennett Fox,
!    Algorithm 647:
!    Implementation and Relative Efficiency of Quasirandom
!    Sequence Generators,
!    ACM Transactions on Mathematical Software,
!    Volume 12, Number 4, December 1986, pages 362-376.
!
!    Pierre L'Ecuyer,
!    Random Number Generation,
!    in Handbook of Simulation,
!    edited by Jerry Banks,
!    Wiley, 1998,
!    ISBN: 0471134031,
!    LC: T57.62.H37.
!
!    Peter Lewis, Allen Goodman, James Miller,
!    A Pseudo-Random Number Generator for the System/360,
!    IBM Systems Journal,
!    Volume 8, 1969, pages 136-143.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
!    should NOT be 0.  On output, SEED has been updated.
!
!    Output, real ( kind = 8 ) R(N), the vector of pseudorandom values.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) k
  integer ( kind = 4 ) seed
  real ( kind = 8 ) r(n)

  do i = 1, n

    k = seed / 127773

    seed = 16807 * ( seed - k * 127773 ) - k * 2836

    if ( seed < 0 ) then
      seed = seed + 2147483647
    end if

    r(i) = real ( seed, kind = 8 ) * 4.656612875D-10

  end do

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


!---------------------------------------------------------------------------------------------------
!
!	filename = grid.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 19/10/2013
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
! Module for grid generations
module grid
  implicit none

contains

!---------------------------------------------------------------------------------------------------
! Adaptative grid
subroutine grid_adap_exp( r, N, Rf, alpha )
  integer, intent( in ) :: N
  double precision, intent( in ) :: Rf, alpha
  double precision, intent( out ) :: r( N )
  double precision :: a, b, h
  integer :: i

  h = 1.0D0 / ( dble( N ) - 1.0D0 )
  a = Rf / ( exp( alpha ) - 1.0D0 )
  b = Rf * exp( -alpha ) / ( exp(-alpha) - 1.0D0 )

  !$omp parallel do private(i)
  do i = 1,N
     r(i) = a * exp( alpha * h * dble( i - 1.0D0 ) ) + b
  end do

end subroutine grid_adap_exp

!---------------------------------------------------------------------------------------------------
! Uniform grid
subroutine grid_unif( r, N, a, b )
  integer, intent( in ) :: N
  double precision, intent( in ) :: a, b
  double precision, intent( out ) :: r(N)
  double precision :: h
  integer :: i

  h = ( b - a ) / ( dble( N ) - 1.0D0 )

  !$omp parallel do private(i)
  do i = 1, N
     r(i) = dble( i - 1.0D0 ) * h
  end do

end subroutine grid_unif

end module grid


PROGRAM test_jacobi

implicit none
integer, parameter :: n=3
double precision :: a(n,n), x(n,n)
double precision, parameter:: abserr=1.0e-09
integer i, j

real ( kind = 8 ) d(n)

integer ( kind = 4 ) it_max
integer ( kind = 4 ) it_num, rot_num

! matrix A
data (a(1,i), i=1,3) /   3.0,  2.0,  4.0 /
data (a(2,i), i=1,3) /   2.0,  0.0,  2.0 /
data (a(3,i), i=1,3) /   4.0, 2.0,  3.0 /

! print a header and the original matrix
write (*,200)
do i=1,n
write (*,201) (a(i,j),j=1,n)
end do

it_max = 100
it_num = 0
rot_num = 0

call jacobi_eigenvalue(n,a,it_max, x,d, it_num, rot_num)

! print solutions
write (*,202)
write (*,201) (d(i),i=1,n)
write (*,203)
do i = 1,n
write (*,201)  (x(i,j),j=1,n)
end do

200 format (' Eigenvalues and eigenvectors (Jacobi method) ',/, &
' Matrix A')
201 format (6f12.6)
202 format (/,' Eigenvalues')
203 format (/,' Eigenvectors')

print*, it_num, rot_num

END PROGRAM test_jacobi

subroutine jacobi_eigenvalue ( n, a, it_max, v, d, it_num, rot_num )

!*****************************************************************************80
!
!! JACOBI_EIGENVALUE carries out the Jacobi eigenvalue iteration.
!
!  Discussion:
!
!    This function computes the eigenvalues and eigenvectors of a
!    real symmetric matrix, using Rutishauser's modfications of the classical
!    Jacobi rotation method with threshold pivoting.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    17 September 2013
!
!  Author:
!
!    FORTRAN90 version by John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the order of the matrix.
!
!    Input, real ( kind = 8 ) A(N,N), the matrix, which must be square, real,
!    and symmetric.
!
!    Input, integer ( kind = 4 ) IT_MAX, the maximum number of iterations.
!
!    Output, real ( kind = 8 ) V(N,N), the matrix of eigenvectors.
!
!    Output, real ( kind = 8 ) D(N), the eigenvalues, in descending order.
!
!    Output, integer ( kind = 4 ) IT_NUM, the total number of iterations.
!
!    Output, integer ( kind = 4 ) ROT_NUM, the total number of rotations.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) bw(n)
  real ( kind = 8 ) c
  real ( kind = 8 ) d(n)
  real ( kind = 8 ) g
  real ( kind = 8 ) gapq
  real ( kind = 8 ) h
  integer ( kind = 4 ) i
  integer ( kind = 4 ) it_max
  integer ( kind = 4 ) it_num
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  integer ( kind = 4 ) l
  integer ( kind = 4 ) m
  integer ( kind = 4 ) p
  integer ( kind = 4 ) q
  integer ( kind = 4 ) rot_num
  real ( kind = 8 ) s
  real ( kind = 8 ) t
  real ( kind = 8 ) tau
  real ( kind = 8 ) term
  real ( kind = 8 ) termp
  real ( kind = 8 ) termq
  real ( kind = 8 ) theta
  real ( kind = 8 ) thresh
  real ( kind = 8 ) v(n,n)
  real ( kind = 8 ) w(n)
  real ( kind = 8 ) zw(n)

  do j = 1, n
    do i = 1, n
      v(i,j) = 0.0D+00
    end do
    v(j,j) = 1.0D+00
  end do

  do i = 1, n
    d(i) = a(i,i)
  end do

  bw(1:n) = d(1:n)
  zw(1:n) = 0.0D+00
  it_num = 0
  rot_num = 0

  do while ( it_num < it_max )

    it_num = it_num + 1
!
!  The convergence threshold is based on the size of the elements in
!  the strict upper triangle of the matrix.
!
    thresh = 0.0D+00
    do j = 1, n
      do i = 1, j - 1
        thresh = thresh + a(i,j) ** 2
      end do
    end do

    thresh = sqrt ( thresh ) / real ( 4 * n, kind = 8 )

    if ( thresh == 0.0D+00 ) then
      exit
    end if

    do p = 1, n
      do q = p + 1, n

        gapq = 10.0D+00 * abs ( a(p,q) )
        termp = gapq + abs ( d(p) )
        termq = gapq + abs ( d(q) )
!
!  Annihilate tiny offdiagonal elements.
!
        if ( 4 < it_num .and. &
             termp == abs ( d(p) ) .and. &
             termq == abs ( d(q) ) ) then

          a(p,q) = 0.0D+00
!
!  Otherwise, apply a rotation.
!
        else if ( thresh <= abs ( a(p,q) ) ) then

          h = d(q) - d(p)
          term = abs ( h ) + gapq

          if ( term == abs ( h ) ) then
            t = a(p,q) / h
          else
            theta = 0.5D+00 * h / a(p,q)
            t = 1.0D+00 / ( abs ( theta ) + sqrt ( 1.0D+00 + theta * theta ) )
            if ( theta < 0.0D+00 ) then
              t = - t
            end if
          end if

          c = 1.0D+00 / sqrt ( 1.0D+00 + t * t )
          s = t * c
          tau = s / ( 1.0D+00 + c )
          h = t * a(p,q)
!
!  Accumulate corrections to diagonal elements.
!
          zw(p) = zw(p) - h
          zw(q) = zw(q) + h
          d(p) = d(p) - h
          d(q) = d(q) + h

          a(p,q) = 0.0D+00
!
!  Rotate, using information from the upper triangle of A only.
!
          do j = 1, p - 1
            g = a(j,p)
            h = a(j,q)
            a(j,p) = g - s * ( h + g * tau )
            a(j,q) = h + s * ( g - h * tau )
          end do

          do j = p + 1, q - 1
            g = a(p,j)
            h = a(j,q)
            a(p,j) = g - s * ( h + g * tau )
            a(j,q) = h + s * ( g - h * tau )
          end do

          do j = q + 1, n
            g = a(p,j)
            h = a(q,j)
            a(p,j) = g - s * ( h + g * tau )
            a(q,j) = h + s * ( g - h * tau )
          end do
!
!  Accumulate information in the eigenvector matrix.
!
          do j = 1, n
            g = v(j,p)
            h = v(j,q)
            v(j,p) = g - s * ( h + g * tau )
            v(j,q) = h + s * ( g - h * tau )
          end do

          rot_num = rot_num + 1

        end if

      end do
    end do

    bw(1:n) = bw(1:n) + zw(1:n)
    d(1:n) = bw(1:n)
    zw(1:n) = 0.0D+00

  end do
!
!  Restore upper triangle of input matrix.
!
  do j = 1, n
    do i = 1, j - 1
      a(i,j) = a(j,i)
    end do
  end do
!
!  Ascending sort the eigenvalues and eigenvectors.
!
  do k = 1, n - 1

    m = k

    do l = k + 1, n
      if ( d(l) < d(m) ) then
        m = l
      end if
    end do

    if ( m /= k ) then

      t    = d(m)
      d(m) = d(k)
      d(k) = t

      w(1:n)   = v(1:n,m)
      v(1:n,m) = v(1:n,k)
      v(1:n,k) = w(1:n)

    end if

  end do

  return
end


program ejemplo1
  use iso_fortran_env, only: wp => real64
  use roots, only: biseccion
  implicit none (type, external)

  real(wp) :: a, b, tol, raiz
  integer :: n, clave

  ! Datos de iniciales
  a = 0.6_wp
  b = 0.8_wp
  tol = 0.5e-8_wp
  n = 100

  ! Determinar la raíz
  call biseccion(f,a,b,n,tol,raiz,clave)
  if (clave == 0) then
     write(*,*) 'Raíz =', raiz
     write(*,*) 'Iteraciones realizadas =', n
  else
     write(*,*) 'Error =', clave
  endif

contains

  real(wp) function f(x)
    ! Función que define la ecuación
    real(wp), intent(in) :: x
    f = cos(x) - x
  end function f

end program ejemplo1


! { dg-do compile }
! { dg-require-effective-target vect_float }
! { dg-require-effective-target vect_intfloat_cvt }
! { dg-additional-options "-ffast-math" }

program calcpi

    implicit none
    real(kind=4):: h,x,sum,pi
    integer:: n,i
    real(kind=4):: f

   f(x) = 4.0/(1.0+x**2)

   n = 2100000000

   h= 1.0 / n
   sum = 0.0
  DO i=1, n
     x = h * (i-0.5)
     sum = sum + f(x)
  END DO
  pi = h * sum
  write(*,*) 'Pi=',pi

end program calcpi

! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } }


C
C     GAUSS METHOD
C
C     DEPENDENCE COMPUTAION WITH AND WITHOUT EXECUTION CONTEXT
C     PRIVATIZATION
C
      SUBROUTINE GAUSS(A, N)
C
      INTEGER N
      REAL A(N,N)
C
      DO L = 1,N-1
         XAUX = A(L,L)
         DO J = L+1, N
            A(L,J) = A(L,J) / XAUX
         ENDDO
         DO I = L+1, N
            XAUX = A(I,L)
            DO K = L+1,N
               A(I,K) = A(I,K) - XAUX*A(L,K)
            ENDDO
         ENDDO
      ENDDO
C
      RETURN
      END


PROGRAM F001

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: VAL_1A = FLOOR((1000.0 - 1.0) / 3.0);
    INTEGER, PARAMETER :: VAL_1B = 3 * ((VAL_1A * (VAL_1A + 1)) / 2);
    INTEGER, PARAMETER :: VAL_2A = FLOOR((1000.0 - 1.0) / 5.0);
    INTEGER, PARAMETER :: VAL_2B = 5 * ((VAL_2A * (VAL_2A + 1)) / 2);
    INTEGER, PARAMETER :: VAL_3A = FLOOR((1000.0 - 1.0) / 15.0);
    INTEGER, PARAMETER :: VAL_3B = 15 * ((VAL_3A * (VAL_3A + 1)) / 2);

    PRINT ('(I0)'), VAL_1B + VAL_2B - VAL_3B

END PROGRAM F001


! Factorials using do while loop

program factorial
implicit none

   ! define variables
   integer :: nfact = 1
   integer :: n = 1

   ! compute factorials
   do while (n <= 10)
      nfact = nfact * n
      n = n + 1
      print*,  (n-1), " ", nfact
   end do
end program factorial


program main
    implicit none
    real, external :: distance
    open(unit=1, file='out.txt')
    write (1,"(A, F0.6)") 'The distance between (-1,1) and (6,2) is ', distance(-1.0, 1.0, 6.0, 2.0)
    close(1)
    stop
end program main

function distance(ax, ay, bx, by)
    implicit none
    real :: ax
    real :: ay
    real :: bx
    real :: by
    real :: distance
    distance = ((bx - ax) ** 2 + (by - ay) ** 2) ** 0.5
    return
end function