       do J = 1, NUPAR
          CUPAR=UPAR(J)

	    g_33j = 0.0

          do K = 2, NUPER - 1
             CUPER=UPER(K)
             g_33j = g_33j + UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))
          end do

	    k = 1
          g_33j = g_33j + 0.5 * UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))

	    k = nuper
          g_33j = g_33j + 0.5 * UPAR(J)*(UPER(K)*DFDUPAR(K,J)-UPAR(J)*DFDUPER(K,J))

	    du = (uper(nuper) - uper(1))/(nuper - 1)

	    ga_33(j) = g_33j * du

       end do

!      the uperp integral is now done; now do parallel

       call EQSIMPSON1D_2(NUPAR, UPAR, ga_33, g_33)


module numz
  integer, parameter:: b8 = selected_real_kind(14)
  real(b8), parameter :: pi = 3.141592653589793239_b8
  integer gene_size
end module

module ran_mod
! module contains three functions
! ran1 returns a uniform random number between 0-1
! spread returns random number between min - max
! normal returns a normal distribution

contains
    function ran1()  !returns random number between 0 - 1
        use numz
        implicit none
        real(b8) ran1,x
        call random_number(x) ! built in fortran 90 random number function
        ran1=x
    end function ran1

    function spread(min,max)  !returns random number between min - max
      use numz
      implicit none
      real(b8) spread
      real(b8) min,max
      spread=(max - min) * ran1() + min
    end function spread

    function normal2(mean2,sigma2)
      use numz
      real     :: normal2, mean2, sigma2
      real(b8) :: mean, sigma
      mean=mean2
      sigma=sigma2
      normal2=normal(mean,sigma)
      return
    end function normal2

    function normal(mean,sigma) !returns a normal distribution
        use numz
        implicit none
        real(b8) normal,tmp
        real(b8) mean,sigma
        integer flag
        real(b8) fac,gsave,rsq,r1,r2
        save flag,gsave
        data flag /0/
        if (flag.eq.0) then
        rsq=2.0_b8
            do while(rsq.ge.1.0_b8.or.rsq.eq.0.0_b8) ! new from for do
                r1=2.0_b8*ran1()-1.0_b8
                r2=2.0_b8*ran1()-1.0_b8
                rsq=r1*r1+r2*r2
            enddo
            fac=sqrt(-2.0_b8*log(rsq)/rsq)
            gsave=r1*fac
            tmp=r2*fac
            flag=1
        else
            tmp=gsave
            flag=0
        endif
        normal=tmp*sigma+mean
        return
    end function normal

end module ran_mod


FUNCTION bino(n,k,p)
!
IMPLICIT NONE
!
! Function arguments
!
INTEGER :: k,n
REAL :: p
REAL :: bino
!
! Local variables
!
REAL :: bico
REAL*8 :: dble
REAL :: factln
!
!     + + + purpose + + +
!     addition to the bico function which returns binomial coefficient
!     as a floating point number.
!
!     modification based on:
!     'numerical recipes - the art of scientific computing',
!     w.h. press, b.p. flannery, s.a. teukolsky, w.t. vetterling
!     cambridge university press, 1986
!     pg 158
!
!     + + + keywords + + +
!     binomial function
!
!     + + + argument declarations + + +
!
!
!     + + + argument definitions + + +
!     n,k    - inputs for computing binomial coefficient
!     p      - probability value
!
!     + + + local variables + + +
!
!
!     + + + local variable definitions + + +
!
!     bico   - computed binomial coefficient
!
!     + + + end specifications + + +
!
bico = anint(exp(factln(n)-factln(k)-factln(n-k)))
bino = bico*(p**dble(k))*((1.0-p)**dble(n-k))
!
END FUNCTION bino

Project Documents/Source Code Original/Bino.f90


program aks
  implicit none

  ! Coefficients of polynomial expansion
  integer(kind=16), dimension(:), allocatable :: coeffs
  integer(kind=16) :: n
  ! Character variable for I/O
  character(len=40) :: tmp

  ! Point #2
  do n = 0, 7
    write(tmp, *) n
    call polynomial_expansion(n, coeffs)
    write(*, fmt='(A)', advance='no') '(x - 1)^'//trim(adjustl(tmp))//' ='
    call print_polynom(coeffs)
  end do

  ! Point #4
  do n = 2, 35
    if (is_prime(n)) write(*, '(I4)', advance='no') n
  end do
  write(*, *)

  ! Point #5
  do n = 2, 124
    if (is_prime(n)) write(*, '(I4)', advance='no') n
  end do
  write(*, *)

  if (allocated(coeffs)) deallocate(coeffs)
contains
  ! Calculate coefficients of (x - 1)^n using binomial theorem
  subroutine polynomial_expansion(n, coeffs)
    integer(kind=16), intent(in) :: n
    integer(kind=16), dimension(:), allocatable, intent(out) :: coeffs
    integer(kind=16) :: i, j

    if (allocated(coeffs)) deallocate(coeffs)

    allocate(coeffs(n + 1))

    do i = 1, n + 1
      coeffs(i) = binomial(n, i - 1)*(-1)**(n - i - 1)
    end do
  end subroutine

  ! Calculate binomial coefficient using recurrent relation, as calculation
  ! using factorial overflows too quickly.
  function binomial(n, k) result (res)
    integer(kind=16), intent(in) :: n, k
    integer(kind=16) :: res
    integer(kind=16) :: i

    if (k == 0) then
      res = 1
      return
    end if

    res = 1
    do i = 0, k - 1
      res = res*(n - i)/(i + 1)
    end do
  end function

  ! Outputs polynomial with given coefficients
  subroutine print_polynom(coeffs)
    integer(kind=16), dimension(:), allocatable, intent(in) :: coeffs
    integer(kind=4) :: i, p
    character(len=40) :: cbuf, pbuf
    logical(kind=1) :: non_zero

    if (.not. allocated(coeffs)) return

    non_zero = .false.

    do i = 1, size(coeffs)
      if (coeffs(i) .eq. 0) cycle

      p = i - 1
      write(cbuf, '(I40)') abs(coeffs(i))
      write(pbuf, '(I40)') p

      if (non_zero) then
        if (coeffs(i) .gt. 0) then
          write(*, fmt='(A)', advance='no') ' + '
        else
          write(*, fmt='(A)', advance='no') ' - '
        endif
      else
        if (coeffs(i) .gt. 0) then
          write(*, fmt='(A)', advance='no') '   '
        else
          write(*, fmt='(A)', advance='no') ' - '
        endif
      endif

      if (p .eq. 0) then
        write(*, fmt='(A)', advance='no') trim(adjustl(cbuf))
      elseif (p .eq. 1) then
        if (coeffs(i) .eq. 1) then
          write(*, fmt='(A)', advance='no') 'x'
        else
          write(*, fmt='(A)', advance='no') trim(adjustl(cbuf))//'x'
        end if
      else
        if (coeffs(i) .eq. 1) then
          write(*, fmt='(A)', advance='no') 'x^'//trim(adjustl(pbuf))
        else
          write(*, fmt='(A)', advance='no') &
            trim(adjustl(cbuf))//'x^'//trim(adjustl(pbuf))
        end if
      end if
      non_zero = .true.
    end do

    write(*, *)
  end subroutine

  ! Test if n is prime using AKS test. Point #3.
  function is_prime(n) result (res)
    integer(kind=16), intent (in) :: n
    logical(kind=1) :: res
    integer(kind=16), dimension(:), allocatable :: coeffs
    integer(kind=16) :: i

    call polynomial_expansion(n, coeffs)
    coeffs(1) = coeffs(1) + 1
    coeffs(n + 1) = coeffs(n + 1) - 1

    res = .true.

    do i = 1, n + 1
      res = res .and. (mod(coeffs(i), n) == 0)
    end do

    if (allocated(coeffs)) deallocate(coeffs)
  end function
end program aks


! fortran_free_source
!
!  This module is part of PERFCODE, written by Bradley J Eck.
!
MODULE solvers
implicit none
contains

!============================================================================
!   Subroutines related to solving linear systems:
!   1. DIAGDOM_PENTA checks for diagonal dominance
!        given the bands of a penta-diagonal matrix
!   2. GAUSS_SEIDEL_PENTA uses the Gauss-Seidel method
!       for iterative solution of a penta-diagonal system
!       of linear equations.
!   3. THOMAS uses the tri-diagonal matrix algorithm to solve
!        a tri-diagonal linear system

!===================================================================
!   \\\\\\\\\\       B E G I N    S U B R O U T I N E ///////////
!   //////////          D I A G D O M _ P E N T A     \\\\\\\\\\\
!===================================================================
!
!   Purpose:    Checks to see if a penta-diagonal matrix is
!               diagonally dominant.  Knowing this helps select
!               a solver.  The routine operates only on the bands
!               of the coefficent matrix.
subroutine diagdom_penta( A, B, C, D, E, n, LB, UB, diagdom)
!  A,B -- lower bands of the penta-diagonal matrix
!   C  -- main diagonal
!  D,E -- upper banks of the penta-diagonal matrix
!   n  -- number of unknowns (size of system)
!  LB  -- lower bandwidth
!  UB  -- upper bandwidth
! tolit-- iteration tolerence
! diagdom-- a logical that stores the result.
!-------------------------------------------------------------------
! VARIABLE DECLARATIONS

! Arguments
integer, intent(in)  :: n, LB, UB
real, intent( in )   :: A(n), B(n), C(n), D(n), E(n)
logical, intent(out) :: diagdom
! Internal Variables
integer              :: k
real                 :: T1, T2, T4, T5
real                 :: tot

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

! set the logical to true, the following loop changes it if
! a row is not diagonally dominant.
diagdom = .true.

do k = 1, n
    ! compute the magnitude of each term in the row of the matrix
    if( k-LB .LT. 1 ) then; T1 = 0. ; else; T1 = abs( A(k) ); endif
    if( k    .EQ. 1 ) then; T2 = 0. ; else; T2 = abs( B(k) ); endif
    if( k    .EQ. n ) then; T4 = 0. ; else; T4 = abs( D(k) ); endif
    if( k+UB .GT. n ) then; T5 = 0. ; else; T5 = abs( E(k) ); endif
    ! Test for diagonal dominance
    tot = T1 + T2 + T4 + T5
    if( tot .GT. abs( C(k) ) ) then
        write(*,*) 'Row ', k, 'of the matrix is not diagonally dominant'
        diagdom = .false.
    endif
enddo
!----------------------------------------------------------------
end subroutine diagdom_penta
!===================================================================
!   \\\\\\\\\\       E N D        S U B R O U T I N E ///////////
!   //////////          D I A G D O M _ P E N T A     \\\\\\\\\\\
!===================================================================

!===================================================================
!   \\\\\\\\\\       B E G I N    S U B R O U T I N E ///////////
!   //////////   G A U S S _ S E I D E L _ P E N T A  \\\\\\\\\\\
!===================================================================

! CAUTION -- This routine DOES NOT check convergence criteria
!            so it possible to converge to the wrong answer.

subroutine gauss_seidel_penta( A, B, C, D, E, F, n , LB, UB, &
                               tolit, maxit, Xold, Xnew, dev, numits )
!  A,B -- lower bands of the penta-diagonal matrix
!   C  -- main diagonal
!  D,E -- upper banks of the penta-diagonal matrix
!   F  -- right hand side (force vector) of linear system
!   n  -- number of unknowns (size of system)
!  LB  -- lower bandwidth
!  UB  -- upper bandwidth
! tolit-- iteration tolerence
! maxit-- maximum number of iterations allowed
! Xold -- initial guess
! Xnew -- converged solution
! dev  -- device for outputting information from the solver
!numits-- number of iterations required to converge
!----------------------------------------------------------------------
!DECLARATIONS
use utilities, only: F_L2_NORM
!arguments
integer, intent(IN) :: n, LB, UB
real, intent(in )   :: A(n), B(n), C(n), D(n), E(n), F(n)
real, intent(in )   :: tolit
integer, intent(in) :: maxit
real, intent(in)    :: Xold(n)
real, intent(out)   :: Xnew(n)
integer, intent(in) :: dev
integer, intent(out):: numits  ! number of iterations required
! internal variables
integer :: k    ! array index
integer :: m    ! iteration index
real :: T1, T2, T4, T5  ! Terms in the equation
real :: relchng(n)  !relative change between iterations
real :: Xtmp(n)     !temporary array to store the progressive solutions

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

!store the starting guess in the temporary array
Xtmp = Xold

! Perform the iterative solution
do m = 1, maxit
!    write(*,*) ' iteration Number = ', m
!    WRITe(*,*) 'Row, T1, T2, T4, T5, Xnew'
    do k = 1, n
        ! compute terms in the expression using if statements to
        ! sort out which terms apply based on the indices
        if( k-LB .LT. 1 ) then; T1 = 0. ; else; T1 = A(k)*Xnew(k-LB); endif
        if( k    .EQ. 1 ) then; T2 = 0. ; else; T2 = B(k)*Xnew(k-1 ); endif
        if( k    .EQ. n ) then; T4 = 0. ; else; T4 = D(k)*Xtmp(k+1 ); endif
        if( k+UB .GT. n ) then; T5 = 0. ; else; T5 = E(k)*Xtmp(k+UB); endif
        ! Compute
        Xnew( k ) = 1./C(k) * ( F(k) - T1 - T2  - T4 - T5 )
!        write(*,10) k, T1, T2, T4, T5, Xnew( k )
    end do
    !compute relative change for this iteration
    do k = 1, n
        relchng(k) = ( Xnew(k) - Xtmp(k) ) / Xtmp(k)
    end do
    ! check for convergence
!    write(dev,*) 'GAUSS_SEIDEL_PENTA: Iteration', m, ', Max rel change:', maxval(abs(relchng)), 'L2_norm:', F_L2_Norm( relchng, n)
    if( maxval( abs( relchng ) ) .LT. tolit .AND. &
          F_L2_Norm( relchng, n) .LT. tolit          ) then
!            write(dev,*) 'GAUSS_SEIDEL_PENTA: Iterations required to converge: ', m
            numits = m
            exit ! exit iteration loop
!    elseif( maxval( abs(relchng) ) .GT. tolit ) then
     else
            Xtmp = Xnew
    endif
!end iteration loop
end do
! Print message if maximum number of iterations was exceeded
if ( m .gt. maxit ) then
    write(*,*) 'GAUSS_SEIDEL_PENTA: maximum number of iterations &
                 &exceeded; program will terminate.'
    STOP
endif

10 format( I12, 10f12.7 )

!---------------------------------------------------------------------------
end subroutine gauss_seidel_penta
!============================================================================
!   \\\\\\\\\\          E N D    S U B R O U T I N E     //////////
!   //////////     G A U S S _ S E I D E L _ P E N T A   \\\\\\\\\\
!============================================================================

!======================================================================
!       \\\\\\\\\\   B E G I N   S U B R O U T I N E   //////////
!       //////////          T H O M A S                \\\\\\\\\\
!======================================================================
SUBROUTINE THOMAS(A,B,C,D,X,N)
integer :: N
REAL A(N), B(N), C(N), D(N), X(N), Q(n+1), G(n+1)
REAL :: WI
integer :: i,j
!
!       Purpose:        Solve a system of linear equations that appear
!                       as a tri-diagonal matrix.
!
!       Source:         This algorithm was handed out in class.
!       Written By:     Brad Eck
!       Revision 0:     Original coding on 19 Feb 09
!
!       A -- Main diagonal
!       B -- Superdiagonal
!       C -- Subdiagonal
!       D -- RHS vector
!       X -- Solution vector
!       N -- number of unknowns
!-----------------------------------------------------------------------

WI=A(1)
G(1)=D(1)/WI
DO I=2,n
        Q(I-1) = B(I-1)/WI
        WI = A(I) - C(I) * Q(I-1)
        G(I) = ( D(I) -C(I) * G(I-1))/WI
END DO

X(N) = G(N)

DO I=2,n
        J = N - I + 1
        X(J) = G(J) - Q(J) * X(J+1)
END DO

END SUBROUTINE THOMAS

!=========================================================================
!       \\\\\\\\\\    E N D   S U B R O U T I N E    //////////
!       //////////         T H O M A S               \\\\\\\\\\
!========================================================================

END MODULE solvers


      SUBROUTINE SHTORH (IMODE,NGP,TA,PS,SIG,QA,RH,QSAT)
C--
C--   SUBROUTINE SHTORH (IMODE,NGP,TA,PS,SIG,QA,RH,QSAT)
C--
C--   Purpose: compute saturation specific humidity and
C--            relative hum. from specific hum. (or viceversa)
C--   Input:   IMODE  : mode of operation
C--            NGP    : no. of grid-points
C--            TA     : abs. temperature
C--            PS     : normalized pressure   (=  p/1000_hPa) [if SIG < 0]
C--                   : normalized sfc. pres. (= ps/1000_hPa) [if SIG > 0]
C--            SIG    : sigma level
C--            QA     : specific humidity in g/kg [if IMODE > 0]
C--            RH     : relative humidity         [if IMODE < 0]
C--            QSAT   : saturation spec. hum. in g/kg
C--   Output:  RH     : relative humidity         [if IMODE > 0]
C--            QA     : specific humidity in g/kg [if IMODE < 0]
C--
      REAL TA(NGP), PS(*), QA(NGP), RH(NGP), QSAT(NGP)
C
C---  1. Compute Qsat (g/kg) from T (degK) and normalized pres. P (= p/1000_hPa)
C        If SIG > 0, P = Ps * sigma, otherwise P = Ps(1) = const.
C
      E0=  6.108E-3
      C1= 17.269
      C2= 21.875
      T0=273.16
      T1= 35.86
      T2=  7.66

      DO 110 J=1,NGP
        IF (TA(J).GE.T0) THEN
          QSAT(J)=E0*EXP(C1*(TA(J)-T0)/(TA(J)-T1))
        ELSE
          QSAT(J)=E0*EXP(C2*(TA(J)-T0)/(TA(J)-T2))
        ENDIF
  110 CONTINUE
C
      IF (SIG.LE.0.0) THEN
        DO 120 J=1,NGP
          QSAT(J)=622.*QSAT(J)/(PS(1)-0.378*QSAT(J))
  120   CONTINUE
      ELSE
        DO 130 J=1,NGP
          QSAT(J)=622.*QSAT(J)/(SIG*PS(J)-0.378*QSAT(J))
  130   CONTINUE
      ENDIF
C
C---  2. Compute rel.hum. RH=Q/Qsat (IMODE>0), or Q=RH*Qsat (IMODE<0)
C
      IF (IMODE.GT.0) THEN
        DO 210 J=1,NGP
          RH(J)=QA(J)/QSAT(J)
  210   CONTINUE
      ELSE IF (IMODE.LT.0) THEN
        DO 220 J=1,NGP
          QA(J)=RH(J)*QSAT(J)
  220   CONTINUE
      ENDIF
C
      RETURN
      END

      SUBROUTINE ZMEDDY (NLON,NLAT,FF,ZM,EDDY)
C
C *** Decompose a field into zonal-mean and eddy component
C
      REAL FF(NLON,NLAT), ZM(NLAT), EDDY(NLON,NLAT)
C
      RNLON=1./NLON
C
      DO 130 J=1,NLAT
C
        ZM(J)=0.
        DO 110 I=1,NLON
          ZM(J)=ZM(J)+FF(I,J)
 110    CONTINUE
        ZM(J)=ZM(J)*RNLON
C
        DO 120 I=1,NLON
          EDDY(I,J)=FF(I,J)-ZM(J)
 120    CONTINUE
C
 130  CONTINUE
C
C--
      RETURN
      END


subroutine SHReturnTapersMap(tapers, eigenvalues, dh_mask, n_dh, sampling, lmax, Ntapers)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine will calculate the eigenvalues and eigenfunctions of the generalized
!	concentration problem where the region of interest R is given by the grid DH_MASK. This
!	matrix is sampled according to the Driscoll and Healy sampling theorem, and possesses a value
!	of 1 inside of R, and 0 elsewhere. Returned tapers and eigenvalues are ordered from the largest
!	to smallest eigenvalue, and the spectral coefficients are packed into a 1D column vector
!	according to the scheme described in YilmIndex.
!
!	The elements Dij are calculated approximately using spherical harmonic transforms.
!	The effective bandwidth of the grid DH_MASK should in general be larger than LMAX by about a factor
!	of 4 or so for accurate results. In addition, as a result of the approximate manner in which
!	the space-concentration kernel is calculated, it is preferable to use SAMPLING=1.
!	As one test of the accuracy, the area of the input grid DH_MASK, is compared to the calculated
!	area given in the elements D(1,1).
!
!	Calling Parameters
!		IN
!			dh_mask		Integer grid sampled according to the Driscoll and Healy sampling
!					theorem. A value of 1 indicates the the grid node is in the concentration
!					domain, and a value of 0 indicates that it is outside. Dimensioned as
!					(n_dh, n_dh) for SAMPLING = 1 or (n_dh, 2*n_dh) for SAMPLING = 2.
!			n_dh		The number of latitude samples in the Driscoll and Healy sampled grid.
!			SAMPLING	1 corresponds to equal sampling (n_dh, n_dh), whereas 2 corresponds
!					to equal spaced grids (n_dh, 2*n_dh).
!			lmax		Maximum spherical harmonic degree of the outpt spherical harmonic coefficients.
!		IN, OPTIONAL
!			ntapers		Number of tapers and eigenvalues to output
!		OUT
!			Tapers		Column vectors contain the spherical harmonic coefficients, packed according
!					to the scheme described in YilmIndex. The dimension of this array is
!					(lmax+1)**2 by (lmax+1)**2, or (lmax+1)**2 by NTapers if NTapers is present.
!			Eigenvalues	A 1-dimensional vector containing the eigenvalues corresponding to the columns
!					of Tapers, dimensioned as (lmax+1)**2.
!
!	Written by Mark Wieczorek (August 2009)
!
!	Copyright (c) 2009, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only : EigValVecSym, ComputeDMap

	implicit none

	real*8, intent(out) ::	tapers(:,:), eigenvalues(:)
	integer, intent(in) ::	dh_mask(:,:), n_dh, sampling, lmax
	integer, intent(in), optional ::	ntapers

	real*8, allocatable ::	dij(:,:)
	integer ::		nlat, nlong, lmax_dh, astat, i, j
	real*8 ::		area, areaf, pi, colat, long_int, lat_int, da

	pi = acos(-1.0d0)

	if (present(ntapers)) then
		if (ntapers > (lmax+1)**2) then
			print*, "Error --- SHRetrunTapersMap"
			print*, "The number of output tapers must be less than or equal to (LMAX+1)**2."
			print*, "LMAX = ", lmax
			print*, "NTAPERS = ", ntapers
			stop
		elseif (size(tapers(:,1)) < (lmax+1)**2 .or. size(tapers(1,:)) < ntapers) then
				print*, "Error --- SHReturnTapersMap"
				print*, "TAPERS must be dimensioned as ((LMAX+1)**2, NTAPERS)."
				print*, "Dimension of TAPERS = ", size(tapers(:,1)), size(tapers(1,:))
				print*, "LMAX = ", lmax
				print*, "NTAPERS = ", ntapers
				stop
		elseif (size(eigenvalues(:)) < ntapers) then
			print*, "Error --- SHReturnTapersMap"
			print*, "EIGENVALUES must be dimensioned as NTAPERS."
			print*, "Dimension of EIGENVALUES = ", size(eigenvalues)
			print*, "NTAPERS = ", ntapers
			stop
		endif
	else
		if (size(tapers(:,1)) < (lmax+1)**2 .or. size(tapers(1,:)) < (lmax+1)**2) then
			print*, "Error --- SHReturnTapersMap"
			print*, "TAPERS must be dimensioned as ((LMAX+1)**2, (LMAX+1)**2)."
			print*, "Dimension of TAPERS = ", size(tapers(:,1)), size(tapers(1,:))
			print*, "LMAX = ", lmax
			stop
		elseif (size(eigenvalues(:)) < (lmax+1)**2) then
			print*, "Error --- SHReturnTapersMap"
			print*, "EIGENVALUES must be dimensioned as (LMAX+1)**2"
			print*, "Dimension of EIGENVALUES = ", size(eigenvalues)
			print*, "LMAX = ", lmax
			stop
		endif
	endif

	if (mod(n_dh,2) /= 0) then
		print*, "Error --- SHReturnTapersMap"
		print*, "Number of samples in latitude must be even for the Driscoll and Healy sampling theorem."
		print*, "N_DH = ", n_dh
		stop
	endif

	nlat = n_dh
	lat_int = pi/dble(nlat)
	if (sampling == 1) then
		nlong = nlat
		long_int = 2.0d0 * lat_int
	elseif (sampling == 2) then
		nlong = 2*nlat
		long_int = lat_int
	else
		print*, "Error --- SHReturnTapersMap"
		print*, "SAMPLING must be either 1 (equally sampled) or 2 (equally spaced)."
		print*, "SAMPLING = ", sampling
		stop
	endif

	if (size(dh_mask(:,1)) < nlat .or. size(dh_mask(1,:)) < nlong) then
		print*, "Error --- SHReturnTapersMap"
		print*, "DH_MASK must be dimensioned as ", nlat, nlong
		print*, "Dimensions of DH_MASK are ", size(dh_mask(:,1)), size(dh_mask(1,:))
		stop
	endif

	lmax_dh = n_dh/2 - 1

	if (lmax_dh < lmax) then
		print*, "Error --- SHReturnTapersMap"
		print*, "The effective bandwith of the input grid DH_MASK must be greater or equal than LMAX."
		print*, "Experience suggests that this should be about 4 times LMAX."
		print*, "LMAX = ", lmax
		print*, "Effective bandwidth of DH_MASK = (N/2 -1) = ", lmax_dh
		stop
	endif

	allocate(dij((lmax+1)**2, (lmax+1)**2), stat = astat)
	if (astat /= 0) then
		print*, "Error --- SHReturnTapersMap"
		print*, "Problem allocating DIJ((LMAX+1)**2,(LMAX+1)**2)"
		print*, "LMAX = ", lmax
		stop
	endif

	call ComputeDMap(Dij, dh_mask, n_dh, sampling, lmax)

	if (present(ntapers)) then
		call EigValVecSym(Dij, (lmax+1)**2, eigenvalues, tapers, k = ntapers)
	else
		call EigValVecSym(Dij, (lmax+1)**2, eigenvalues, tapers)
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Check and see how good the solutions are.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	area = 0.0d0
	areaf = 0.0d0

	do i=2, nlat
		colat = dble(i-1)*lat_int
		do j=1, nlong
			da = -( cos(colat + lat_int/2.0d0) - cos(colat - lat_int/2.0d0) ) * long_int
			area = area + da
			if (dh_mask(i,j) == 1) areaf = areaf + da
		enddo
	enddo

	da = 2.0d0 * pi * (1.0d0 - cos(lat_int/2.0d0) )
	area = area + 2.0d0 * da
	if (dh_mask(1,1) == 1) areaf = areaf +  da
	if (dh_mask(nlat,nlong) == 1) areaf = areaf + da

	print*, "SHReturnTapersMap --- (Area of entire grid) / 4pi = ", area / 4.0d0 / pi
	print*, "SHReturnTapersMap --- (Area of DH_MASK) / 4pi = ", areaf / 4.0d0 / pi
	print*, "SHReturnTapersMap --- (Area of DH_MASK) / 4pi / D00 = ", areaf / 4.0d0 / pi / Dij(1,1)

	deallocate(dij)

end subroutine SHReturnTapersMap


      PROGRAM xbroydn
C     driver for routine broydn
      INTEGER N
      PARAMETER(N=2)
      INTEGER i
      REAL x(N),f(N)
      LOGICAL check
      x(1)=2.
      x(2)=.5
      call broydn(x,N,check)
      call funcv(N,x,f)
      if (check) then
        write(*,*) 'Convergence problems.'
      endif
      write(*,'(1x,a5,t10,a1,t22,a1)') 'Index','x','f'
      do 11 i=1,N
        write(*,'(1x,i2,2x,2f12.6)') i,x(i),f(i)
11    continue
      END
      SUBROUTINE funcv(n,x,f)
      INTEGER n
      REAL x(n),f(n)
      f(1)=x(1)**2+x(2)**2-2.
      f(2)=exp(x(1)-1.)+x(2)**3-2.
      return
      END

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


	Program pai
	Implicit none
	integer max
c declarations
	Real volume, x, y, area
	Integer i, pi3, pi2

	print*,'input the number for try'
	read(5,*) max
	pi2=0
c execute
	Do 10 i=1, max
C generate (x,y) within [-1,1]:
	   x = rand()*2-1
	   y = rand()*2-1
	   If ((x*x + y*y ) .LE. 1) pi2 = pi2 + 1
	   area = 4.0 * pi2/Real(i)

 	   if(mod(i,1000).eq.1) Write(6,100) i, area
 10 	Continue

        Write(6,100) max, area
100	format(1x,'try= ',i8,2x,'pai=',f8.4)
	stop
	end


      program int_expr
         implicit none
         integer zero, one, two, a, b, c, d

         zero = 0
         one  = 1
         two  = 2

         if (zero .ne. 0 .or. one .ne. 1 .or. two .ne. 2) goto 99

         zero = zero**zero + (-one/one)
         if (zero .ne. 0) goto 99

         one = +one*one + 0 + zero*one + one - 1
         if (one .ne. 1) goto 99

         one = one**one + one**two/4
         if (one .ne. 1) goto 99

         two = two**two/two+zero+two**zero-one
         if (two .ne. 2) goto 99

         a = one*(one - 2)
         if (a .ne. -1) goto 99

         b = -a
         if (b .ne. 1) goto 99

         c = 13*a/4
         d = 13*b/4
         if (c .ne. -3 .or. d .ne. 3) goto 99

         c = +1.01*one
         d = +1.99*one

         if (c .ne. 1 .or. d .ne. 1) goto 99

         c = -1.01*two
         d = -1.99*two

         if (c .ne. -2 .or. d .ne. -3) goto 99

C These tests passes
         goto 100

C These tests failed
99       stop 1

100   end program


program ejemplo2
  use iso_fortran_env, only: wp => real64
  use roots, only: fzero
  implicit none (type, external)
  real(wp) :: a,b
  real(wp) :: rerror, aerror
  integer :: code

  a = 3.0_wp
  b = 4.0_wp
  rerror = 5.0e-8_wp
  aerror = 0.0_wp

  call fzero ( f, a, b, rerror, aerror, code )
  write(*,'(a,i0)') 'Code = ', code
  write(*,'(a,g0)') 'Root = ', a

contains

  real(wp) function f(x)
    real(wp), intent(in) :: x
    f = 1.0_wp/( x - 3.0_wp ) - 6.0_wp
  end function f

end program ejemplo2


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Integer arithmetic operations (+, *, - , /), including
*   constant folding.

	program p
    	parameter (n=24)
	integer rslts(N), expect(N)
	data expect / -7, -398, 7, 1,
     +                6, 87, 2, -8,
     +                -8, 73, -4, -2,
     +                -7, 560, -3, 15,
     +                -7, 1, 0, -2,
     +                100000000, 10, 90, -1  /

	data i7, in1, i4, in4, i9 / 7, -1, 4, -4, 9 /

c  tests 1 - 4:  unary minus and plus operators:

 	rslts(1) = -i7
	rslts(2) = +(-398)
  	rslts(3) = -(-(+i7))
  	rslts(4) = -(-1)

c  tests 5 - 8:  plus operator:

   	rslts(5) = i7 + in1
    	rslts(6) = i7 + 80
    	rslts(7) = 3 + in1
     	rslts(8) = -3+(-5)

c  tests 9 - 12:  minus operator:

     	rslts(9) = in1 - i7
     	rslts(10) = 80 - i7
      	rslts(11) = in1 - 3
       	rslts(12) = -5-(-3)

c  tests 13 - 16:  multiply operator:

	rslts(13) = in1 * i7
	rslts(14) = 80 * i7
	rslts(15) = in1 * 3
	rslts(16) = -5 * (-3)

c  tests 17 - 24:  divide operator:

	rslts(17) = i7 / in1
        rslts(18) = i7 / i4
        rslts(19) = 1 / in4
	rslts(20) = (-8) / 3
	rslts(21) = 900000000 / i9
	rslts(22) = -51 / (-5)
        rslts(23) = 900000000 / 10000000
	rslts(24) = i7 / (-4)

c  check results:

	call check(rslts, expect, N)
	end


program test_generalized
use types, only: dp
use utils, only: stop_error, assert
use linalg_feast, only: eigh
implicit none

real(dp), parameter :: eps = 1e-9_dp
real(dp), dimension(2, 2) :: A = reshape([2, -4, -4, 2], [2, 2])
real(dp) :: B(2, 2) = reshape([2, 1, 1, 2], [2, 2])
real(dp) :: Emin=-10, Emax=10
integer :: M0=2 ! (Initial) subspace dimension
real(dp), allocatable :: lam(:), c(:, :), r(:)
real(dp) :: norm
integer :: i

allocate(lam(M0))
allocate(r(M0))
allocate(c(2,M0))

call eigh(A, B, Emin, Emax, M0, lam, c)

print *, 'Eigenvalues'
do i = 1, M0
    print *, i, lam(i)
end do
print *,'Eigenvectors'
do i=1, M0
    print *,i,"(",c(1,i),c(2,i),")"
end do

call assert(all(abs(lam - [-2._dp/3, 6._dp]) < eps))
do i = 1, 2
    ! Test that c(:, i) are eigenvectors:
    r = matmul(A-lam(i)*B, c(:, i))
    call assert(sqrt(dot_product(r, r)) < eps)
    ! Test that eigenvectors are properly normalized:
    norm = dot_product(c(:, i), matmul(B, c(:, i)))
    call assert(abs(norm - 1) < eps)
end do

end program


MODULE NEWTON_MOD
IMPLICIT NONE
PUBLIC :: F, FP
CONTAINS
!==============================================================================
FUNCTION F(X,URef,RefHt,HubHt) RESULT (Y)
USE NWTC_Library
REAL(ReKi), INTENT(IN) :: X
!REAL(ReKi), INTENT(IN) :: V_10
REAL(ReKi), INTENT(IN) :: URef
REAL(ReKi), INTENT(IN) :: RefHt
REAL(ReKi), INTENT(IN) :: HubHt
REAL(ReKi)             :: Y
REAL(ReKi)             :: C_1
REAL(ReKi)             :: C_2
REAL(ReKi)             :: D_1
REAL(ReKi)             :: D_2
REAL(ReKi)             :: D_3
REAL(ReKi)             :: D_4

IF ( EqualRealNos( RefHt, 10.0_ReKi ) ) THEN
   C_1=1.0-0.41*0.06*LOG(600.0/3600.0)
   C_2=0.41*0.06*0.043*LOG(600.0/3600.0)
   Y=C_1*X-C_2*X*X-URef
ELSEIF ( EqualRealNos( RefHt, HubHt) )  THEN
   D_1=1.0-0.41*0.06*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_2=0.41*0.06*0.043*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_3=D_1*0.0573*LOG(RefHt/10.0)
   D_4=D_2*0.0573*LOG(RefHt/10.0)
   Y=D_1*X-D_2*X*X+D_3*X*(1.0+0.15*X)**0.5-D_4*X*X*(1.0+0.15*X)**0.5-URef
ELSE
   Y = -9999999
ENDIF

END FUNCTION F
!==============================================================================
FUNCTION FP(X,URef,RefHt,HubHt) RESULT (Y)
USE NWTC_Library
REAL(ReKi), INTENT(IN) :: X
REAL(ReKi), INTENT(IN) :: URef
REAL(ReKi), INTENT(IN) :: RefHt
REAL(ReKi), INTENT(IN) :: HubHt
REAL(ReKi)             :: Y
REAL(ReKi)             :: C_1
REAL(ReKi)             :: C_2
REAL(ReKi)             :: D_1
REAL(ReKi)             :: D_2
REAL(ReKi)             :: D_3
REAL(ReKi)             :: D_4

IF ( EqualRealNos( RefHt, 10.0_ReKi ) ) THEN
   C_1 = 1.0-0.41*0.06*LOG(600.0/3600.0)
   C_2 = 0.41*0.06*0.043*LOG(600.0/3600.0)
   Y   = C_1-2.0*C_2*X
ELSEIF ( EqualRealNos( RefHt, HubHt) )  THEN
   C_1 = 1.0 - 0.41  * 0.06 * LOG(600.0/3600.0)
   C_2 = 0.41 * 0.06*0.043  * LOG(600.0/3600.0)
   D_1 = 1.0-0.41*0.06*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_2 = 0.41*0.06*0.043*LOG(600.0/3600.0)*(RefHt/10.0)**(-0.22)
   D_3 = D_1*0.0573*LOG(RefHt/10.0)
   D_4 = D_2*0.0573*LOG(RefHt/10.0)
   Y   = D_1-2.0*D_2*X+D_3*((1.0+0.15*X)**0.5+0.15*X/2.0/(1.0+0.15*X)**0.5)  &
         -D_4*(2.0*X*(1.0+0.15*X)**0.5+0.15*X*X/2.0/(1.0+0.15*X)**0.5)
ELSE
   Y = -9999999
ENDIF

END FUNCTION FP
!==============================================================================
END MODULE NEWTON_MOD

SUBROUTINE ROOT_SEARCHING(X0,X,URef,RefHt,HubHt)
USE NEWTON_MOD
USE NWTC_Library
IMPLICIT NONE

REAL(ReKi), PARAMETER     :: TOL=1.0E-5

REAL(ReKi), INTENT(IN   ) :: URef
REAL(ReKi), INTENT(IN   ) :: RefHt
REAL(ReKi), INTENT(IN   ) :: HubHt
REAL(ReKi), INTENT(IN   ) :: X0
REAL(ReKi), INTENT(  OUT) :: X

X=X0
DO  ! bjj: I'd like this better if there were absolutely no way to have an infinite loop here...
   X = X - F(X,URef,RefHt,HubHt) / FP(X,URef,RefHt,HubHt)
   IF (ABS(F(X,URef,RefHt,HubHt)) < TOL) THEN
      EXIT
   END IF

END DO
END SUBROUTINE ROOT_SEARCHING


module demo_svd
use, intrinsic :: iso_fortran_env, only: stderr=>error_unit, sp=>real32
implicit none

integer, parameter :: LRATIO=8
integer, parameter :: M=3, N=3

integer, parameter :: Lwork = LRATIO*M !at least 5M for sgesvd

real(sp) :: U(M,M), VT(N,N)
real(sp) :: S(N), SWORK(LRATIO*M) !this Swork is real

interface
  module integer function svd(A, B) result(info)
    real(sp), intent(in) :: A(M, N), B(M, 1)
  end function svd
end interface

contains

subroutine errchk(info)

integer, intent(in) :: info

if (info /= 0) then
  write(stderr,*) 'SGESVD return code', info
  if (info > 0) write(stderr,'(A,I3,A)') 'index #',info,' has sigma=0'
  stop 1
endif

end subroutine errchk

end module demo_svd

program demo
! FIXME not for PGI 18.10
! use, intrinsic :: iso_fortran_env, only: compiler_version
use demo_svd
implicit none

integer :: info
real(sp) :: A(M, N), B(M,1)

! print *,compiler_version()

A = reshape([3.,       1., 1., &
             sqrt(2.), 2., 0., &
             0.,       1., 1.], shape(A), order=[2,1])

B = reshape([8., 4.+sqrt(2.), 5.], shape(B), order=[2,1])

info = svd(A, B)

call errchk(info)

print *,'OK: Fortran SVD'

end program


program ex3p2
    use mt_mod
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100)
    real(kind=rk), parameter :: pi = 4.0*atan(1.0)
    real(kind=rk) :: fsum=0, fmean, V, r=1, err
    integer(kind=ik), parameter :: N=100000
    integer(kind=ik) :: d, i

    call init_genrand64(int(123465, ik))

    do d=1, 15
        !Count the number of hits
        do i=1, N
            fsum=fsum+f(d)
        end do

        !Get the statistics, formula for error from lecture notes
        fmean=fsum/N
        err=(2*r)**d*sqrt(fsum-fsum**2/N)/N

        !Volume, with V_e being the volume of a n-cube (or d-cube with these variables)
        V=(2*r)**d*fmean

        !Print results and reset sum for next dimension
        print('(A, I2, 4X, A, f6.4, 4X, A, f6.4)'),"Dimension: ",d,"Volume: ",V,"Error: +/- ",err
        fsum=0
    end do

contains
real(kind=rk) function f(dim)
    integer(kind=ik), intent(in) :: dim
    integer(kind=ik) :: k
    real(kind=rk), dimension(dim) :: arr
    real(kind=rk) :: sq

    !Generate a list of random points on interval [-r, r] based on given dimension
    arr=[((r*(2*genrand64_real1()-1))**2, k=1, dim, 1)]

    !Check if the random coordinates hit inside the sphere
    sq=sum(arr)
    if(sq<(r*r)) then
        f=1     !hit
    else
        f=0     !no hit
    end if
end function f
end program ex3p2


program floor_02
  real, parameter :: a1 = 3.3 ! 3
  real, parameter :: a2 = 3.5 ! 3
  real, parameter :: a3 = 3.7 ! 3
  real, parameter :: b1 = -3.3 ! -4
  real, parameter :: b2 = -3.5 ! -4
  real, parameter :: b3 = -3.7 ! -4
  integer, parameter :: x1 = floor(a1) ! 3
  integer, parameter :: x2 = floor(a2) ! 3
  integer, parameter :: x3 = floor(a3) ! 3
  integer, parameter :: y1 = floor(b1) ! -4
  integer, parameter :: y2 = floor(b2) ! -4
  integer, parameter :: y3 = floor(b3) ! -4
  print*, x1, x2, x3
  print*, y1, y2, y3
end program


      subroutine asset_path ( s0, mu, sigma, t1, n, seed, s )

c*********************************************************************72
c
cc ASSET_PATH simulates the behavior of an asset price over time.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 February 2012
c
c  Author:
c
c    Original MATLAB version by Desmond Higham.
c    FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Desmond Higham,
c    Black-Scholes for Scientific Computing Students,
c    Computing in Science and Engineering,
c    November/December 2004, Volume 6, Number 6, pages 72-79.
c
c  Parameters:
c
c    Input, double precision S0, the asset price at time 0.
c
c    Input, double precision MU, the expected growth rate.
c
c    Input, double precision SIGMA, the volatility of the asset.
c
c    Input, double precision T1, the expiry date.
c
c    Input, integer N, the number of steps to take between 0 and T1.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision S(0:N), the option values from time 0 to T1
c    in equal steps.
c
      implicit none

      integer n

      double precision dt
      integer i
      double precision mu
      double precision p
      double precision r(n)
      double precision s(0:n)
      double precision s0
      integer seed
      double precision sigma
      double precision t1

      dt = t1 / dble ( n )

      call r8vec_normal_01 ( n, seed, r )

      s(0) = s0
      p = s0
      do i = 1, n
        p = p * exp ( ( mu - sigma * sigma ) * dt
     &    + sigma * sqrt ( dt ) * r(i) )
        s(i) = p
      end do

      return
      end
      subroutine binomial ( s0, e, r, sigma, t1, m, c )

c*********************************************************************72
c
cc BINOMIAL uses the binomial method for a European call.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 February 2012
c
c  Author:
c
c    Original MATLAB version by Desmond Higham.
c    FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Desmond Higham,
c    Black-Scholes for Scientific Computing Students,
c    Computing in Science and Engineering,
c    November/December 2004, Volume 6, Number 6, pages 72-79.
c
c  Parameters:
c
c    Input, double precision S0, the asset price at time 0.
c
c    Input, double precision E, the exercise price.
c
c    Input, double precision R, the interest rate.
c
c    Input, double precision SIGMA, the volatility of the asset.
c
c    Input, double precision T1, the expiry date.
c
c    Input, integer M, the number of steps to take
c    between 0 and T1.
c
c    Output, double precision C, the option value at time 0.
c
      implicit none

      double precision a
      double precision b
      double precision c
      double precision d
      double precision dt
      double precision e
      integer i
      integer m
      integer n
      double precision p
      double precision r
      double precision s0
      double precision sigma
      double precision t1
      double precision u
      double precision w(1:m+1)
c
c  Time stepsize.
c
      dt = t1 / dble ( m )

      a = 0.5D+00 * ( exp ( - r * dt ) + exp ( ( r + sigma**2 ) * dt ) )

      d = a - sqrt ( a * a - 1.0D+00 )
      u = a + sqrt ( a * a - 1.0D+00 )

      p = ( exp ( r * dt ) - d ) / ( u - d )

      do i = 1, m + 1
        w(i) = max ( s0 * d**(m+1-i) * u**(i-1) - e, 0.0D+00 )
      end do
c
c  Trace backwards to get the option value at time 0.
c
      do n = m, 1, -1
        do i = 1, n
          w(i) = ( 1.0D+00 - p ) * w(i) + p * w(i+1)
        end do
      end do

      do i = 1, m + 1
        w(i) = exp ( - r * t1 ) * w(i)
      end do

      c = w(1)

      return
      end
      subroutine bsf ( s0, t0, e, r, sigma, t1, c )

c*********************************************************************72
c
cc BSF evaluates the Black-Scholes formula for a European call.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 February 2012
c
c  Author:
c
c    Original MATLAB version by Desmond Higham.
c    FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Desmond Higham,
c    Black-Scholes for Scientific Computing Students,
c    Computing in Science and Engineering,
c    November/December 2004, Volume 6, Number 6, pages 72-79.
c
c  Parameters:
c
c    Input, double precision S0, the asset price at time T0.
c
c    Input, double precision T0, the time at which the asset price is known.
c
c    Input, double precision E, the exercise price.
c
c    Input, double precision R, the interest rate.
c
c    Input, double precision SIGMA, the volatility of the asset.
c
c    Input, double precision T1, the expiry date.
c
c    Output, double precision C, the value of the call option.
c
      implicit none

      double precision c
      double precision d1
      double precision d2
      double precision e
      double precision n1
      double precision n2
      double precision r
      double precision s0
      double precision sigma
      double precision t0
      double precision t1
      double precision tau

      tau = t1 - t0

      if ( 0.0D+00 .lt. tau ) then

        d1 = ( log ( s0 / e ) + ( r + 0.5D+00 * sigma * sigma ) * tau )
     &    / ( sigma * sqrt ( tau ) )

        d2 = d1 - sigma * sqrt ( tau )

        n1 = 0.5D+00 * ( 1.0D+00 + erf ( d1 / sqrt ( 2.0D+00 ) ) )
        n2 = 0.5D+00 * ( 1.0D+00 + erf ( d2 / sqrt ( 2.0D+00 ) ) )

        c = s0 * n1 - e * exp ( - r * tau ) * n2

      else

        c = max ( s0 - e, 0.0D+00 )

      end if

      return
      end
      subroutine forward ( e, r, sigma, t1, nx, nt, smax, u )

c*********************************************************************72
c
cc FORWARD uses the forward difference method to value a European call option.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 February 2012
c
c  Author:
c
c    Original MATLAB version by Desmond Higham.
c    FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Desmond Higham,
c    Black-Scholes for Scientific Computing Students,
c    Computing in Science and Engineering,
c    November/December 2004, Volume 6, Number 6, pages 72-79.
c
c  Parameters:
c
c    Input, double precision E, the exercise price.
c
c    Input, double precision R, the interest rate.
c
c    Input, double precision SIGMA, the volatility of the asset.
c
c    Input, double precision T1, the expiry date.
c
c    Input, integer NX, the number of "space" steps used to
c    divide the interval [0,L].
c
c    Input, integer NT, the number of time steps.
c
c    Input, double precision SMAX, the maximum value of S to consider.
c
c    Output, double precision U(NX-1,NT+1), the value of the European
c    call option.
c
      implicit none

      integer nt
      integer nx

      double precision a(2:nx-1)
      double precision b(1:nx-1)
      double precision c(1:nx-2)
      double precision dt
      double precision dx
      double precision e
      integer i
      integer j
      double precision p
      double precision r
      double precision sigma
      double precision smax
      double precision t
      double precision t1
      double precision u(nx-1,nt+1)
      double precision u0

      dt = t1 / dble ( nt )
      dx = smax / dble ( nx )

      do i = 1, nx - 1
        b(i) = 1.0D+00 - r * dt - dt * ( sigma * i )**2
      end do

      do i = 1, nx - 2
        c(i) = 0.5D+00 * dt * ( sigma * i )**2 + 0.5D+00 * dt * r * i
      end do

      do i = 2, nx - 1
        a(i) = 0.5D+00 * dt * ( sigma * i )**2 - 0.5D+00 * dt * r * i
      end do

      u0 = 0.0D+00
      do i = 1, nx - 1
        u0 = u0 + dx
        u(i,1) = max ( u0 - e, 0.0D+00 )
      end do

      do j = 1, nt

        t = dble ( j - 1 ) * t1 / dble ( nt )

        p = 0.5D+00 * dt * ( nx - 1 )
     &    * ( sigma * sigma * ( nx - 1 ) + r )
     &    * ( smax - e * exp ( - r * t ) )

        do i = 1, nx - 1
          u(i,j+1) = b(i) * u(i,j)
        end do

        do i = 1, nx - 2
          u(i,j+1) = u(i,j+1) + c(i) * u(i+1,j)
        end do

        do i = 2, nx - 1
          u(i,j+1) = u(i,j+1) + a(i) * u(i-1,j)
        end do

        u(nx-1,j+1) = u(nx-1,j+1) + p

      end do

      return
      end
      subroutine get_unit ( iunit )

c*********************************************************************72
c
cc GET_UNIT returns a free FORTRAN unit number.
c
c  Discussion:
c
c    A "free" FORTRAN unit number is a value between 1 and 99 which
c    is not currently associated with an I/O device.  A free FORTRAN unit
c    number is needed in order to open a file with the OPEN command.
c
c    If IUNIT = 0, then no free FORTRAN unit could be found, although
c    all 99 units were checked (except for units 5, 6 and 9, which
c    are commonly reserved for console I/O).
c
c    Otherwise, IUNIT is a value between 1 and 99, representing a
c    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
c    are special, and will never return those values.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 September 2013
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Output, integer IUNIT, the free unit number.
c
      implicit none

      integer i
      integer iunit
      logical value

      iunit = 0

      do i = 1, 99

        if ( i .ne. 5 .and. i .ne. 6 .and. i .ne. 9 ) then

          inquire ( unit = i, opened = value, err = 10 )

          if ( .not. value ) then
            iunit = i
            return
          end if

        end if

10      continue

      end do

      return
      end
      subroutine mc ( s0, e, r, sigma, t1, m, seed, conf )

c*********************************************************************72
c
cc MC uses Monte Carlo valuation on a European call.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 February 2012
c
c  Author:
c
c    Original MATLAB version by Desmond Higham.
c    FORTRAN77 version by John Burkardt.
c
c  Reference:
c
c    Desmond Higham,
c    Black-Scholes for Scientific Computing Students,
c    Computing in Science and Engineering,
c    November/December 2004, Volume 6, Number 6, pages 72-79.
c
c  Parameters:
c
c    Input, double precision S0, the asset price at time 0.
c
c    Input, double precision E, the exercise price.
c
c    Input, double precision R, the interest rate.
c
c    Input, double precision SIGMA, the volatility of the asset.
c
c    Input, double precision T1, the expiry date.
c
c    Input, integer M, the number of simulations.
c
c    Input/output, integer SEED, a seed for the random
c    number generator.
c
c    Output, double precision CONF(2), the estimated range of the valuation.
c
      implicit none

      integer m

      double precision conf(2)
      double precision e
      integer i
      double precision pmean
      double precision pvals(m)
      double precision r
      double precision s0
      integer seed
      double precision sigma
      double precision std
      double precision svals(m)
      double precision t1
      double precision u(m)
      double precision width

      call r8vec_normal_01 ( m, seed, u )

      do i = 1, m
        svals(i) = s0 * exp ( ( r - 0.5D+00 * sigma * sigma ) * t1
     &    + sigma * sqrt ( t1 ) * u(i) )
      end do

      do i = 1, m
        pvals(i) = exp ( - r * t1 ) * max ( svals(i) - e, 0.0D+00 )
      end do

      pmean = 0.0D+00
      do i = 1, m
        pmean = pmean + pvals(i)
      end do
      pmean = pmean / dble ( m )

      std = 0.0D+00
      do i = 1, m
        std = std + ( pvals(i) - pmean ) ** 2
      end do
      std = sqrt ( std / dble ( m - 1 ) )

      width = 1.96D+00 * std / sqrt ( dble ( m ) )

      conf(1) = pmean - width
      conf(2) = pmean + width

      return
      end
      function r8_normal_01 ( seed )

c*********************************************************************72
c
cc R8_NORMAL_01 returns a unit pseudonormal R8.
c
c  Discussion:
c
c    Because this routine uses the Box Muller method, it requires pairs
c    of uniform random values to generate a pair of normal random values.
c    This means that on every other call, the code can use the second
c    value that it calculated.
c
c    However, if the user has changed the SEED value between calls,
c    the routine automatically resets itself and discards the saved data.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    08 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision R8_NORMAL_01, a sample of the standard normal PDF.
c
      implicit none

      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r1
      double precision r2
      double precision r8_normal_01
      double precision r8_uniform_01
      integer seed
      integer seed1
      integer seed2
      integer seed3
      integer used
      double precision v1
      double precision v2

      save seed1
      save seed2
      save seed3
      save used
      save v2

      data seed2 / 0 /
      data used / 0 /
      data v2 / 0.0D+00 /
c
c  If USED is odd, but the input SEED does not match
c  the output SEED on the previous call, then the user has changed
c  the seed.  Wipe out internal memory.
c
      if ( mod ( used, 2 ) .eq. 1 ) then

        if ( seed .ne. seed2 ) then
          used = 0
          seed1 = 0
          seed2 = 0
          seed3 = 0
          v2 = 0.0D+00
        end if

      end if
c
c  If USED is even, generate two uniforms, create two normals,
c  return the first normal and its corresponding seed.
c
      if ( mod ( used, 2 ) .eq. 0 ) then

        seed1 = seed

        r1 = r8_uniform_01 ( seed )

        if ( r1 .eq. 0.0D+00 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8_NORMAL_01 - Fatal error!'
          write ( *, '(a)' ) '  R8_UNIFORM_01 returned a value of 0.'
          stop
        end if

        seed2 = seed

        r2 = r8_uniform_01 ( seed )

        seed3 = seed

        v1 = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 )
        v2 = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 )

        r8_normal_01 = v1
        seed = seed2
c
c  If USED is odd (and the input SEED matched the output value from
c  the previous call), return the second normal and its corresponding seed.
c
      else

        r8_normal_01 = v2
        seed = seed3

      end if

      used = used + 1

      return
      end
      function r8_uniform_01 ( seed )

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

      double precision r8_uniform_01
      integer k
      integer seed

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

      k = seed / 127773

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

      if ( seed .lt. 0 ) then
        seed = seed + 2147483647
      end if

      r8_uniform_01 = dble ( seed ) * 4.656612875D-10

      return
      end
      subroutine r8vec_normal_01 ( n, seed, x )

c*********************************************************************72
c
cc R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c    The standard normal probability distribution function (PDF) has
c    mean 0 and standard deviation 1.
c
c    This routine can generate a vector of values on one call.  It
c    has the feature that it should provide the same results
c    in the same order no matter how we break up the task.
c
c    The Box-Muller method is used, which is efficient, but
c    generates an even number of values each time.  On any call
c    to this routine, an even number of new values are generated.
c    Depending on the situation, one value may be left over.
c    In that case, it is saved for the next call.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2006
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of values desired.  If N is negative,
c    then the code will flush its internal memory; in particular,
c    if there is a saved value to be used on the next call, it is
c    instead discarded.  This is useful if the user has reset the
c    random number seed, for instance.
c
c    Input/output, integer SEED, a seed for the random number generator.
c
c    Output, double precision X(N), a sample of the standard normal PDF.
c
c  Local parameters:
c
c    Local, integer MADE, records the number of values that have
c    been computed.  On input with negative N, this value overwrites
c    the return value of N, so the user can get an accounting of
c    how much work has been done.
c
c    Local, integer SAVED, is 0 or 1 depending on whether there is a
c    single saved value left over from the previous call.
c
c    Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of
c    X that we need to compute.  This starts off as 1:N, but is adjusted
c    if we have a saved value that can be immediately stored in X(1),
c    and so on.
c
c    Local, double precision Y, the value saved from the previous call, if
c    SAVED is 1.
c
      implicit none

      integer n

      integer i
      integer m
      integer made
      double precision pi
      parameter ( pi = 3.141592653589793D+00 )
      double precision r(2)
      double precision r8_uniform_01
      integer saved
      integer seed
      double precision x(n)
      integer x_hi_index
      integer x_lo_index
      double precision y

      save made
      save saved
      save y

      data made / 0 /
      data saved / 0 /
      data y / 0.0D+00 /
c
c  I'd like to allow the user to reset the internal data.
c  But this won't work properly if we have a saved value Y.
c  I'm making a crock option that allows the user to signal
c  explicitly that any internal memory should be flushed,
c  by passing in a negative value for N.
c
      if ( n .lt. 0 ) then
        n = made
        made = 0
        saved = 0
        y = 0.0D+00
        return
      else if ( n .eq. 0 ) then
        return
      end if
c
c  Record the range of X we need to fill in.
c
      x_lo_index = 1
      x_hi_index = n
c
c  Use up the old value, if we have it.
c
      if ( saved .eq. 1 ) then
        x(1) = y
        saved = 0
        x_lo_index = 2
      end if
c
c  Maybe we don't need any more values.
c
      if ( x_hi_index - x_lo_index + 1 .eq. 0 ) then
c
c  If we need just one new value, do that here to avoid null arrays.
c
      else if ( x_hi_index - x_lo_index + 1 .eq. 1 ) then

        r(1) = r8_uniform_01 ( seed )

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

        r(2) = r8_uniform_01 ( seed )

        x(x_hi_index) =
     &           sqrt ( -2.0D+00 * log ( r(1) ) )
     &           * cos ( 2.0D+00 * pi * r(2) )
        y =      sqrt ( -2.0D+00 * log ( r(1) ) )
     &           * sin ( 2.0D+00 * pi * r(2) )

        saved = 1

        made = made + 2
c
c  If we require an even number of values, that's easy.
c
      else if ( mod ( x_hi_index - x_lo_index + 1, 2 ) .eq. 0 ) then

        do i = x_lo_index, x_hi_index, 2

          call r8vec_uniform_01 ( 2, seed, r )

          x(i) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * cos ( 2.0D+00 * pi * r(2) )

          x(i+1) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * sin ( 2.0D+00 * pi * r(2) )

        end do

        made = made + x_hi_index - x_lo_index + 1
c
c  If we require an odd number of values, we generate an even number,
c  and handle the last pair specially, storing one in X(N), and
c  saving the other for later.
c
      else

        do i = x_lo_index, x_hi_index - 1, 2

          call r8vec_uniform_01 ( 2, seed, r )

          x(i) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * cos ( 2.0D+00 * pi * r(2) )

          x(i+1) =
     &      sqrt ( -2.0D+00 * log ( r(1) ) )
     &      * sin ( 2.0D+00 * pi * r(2) )

        end do

        call r8vec_uniform_01 ( 2, seed, r )

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

        y = sqrt ( -2.0D+00 * log ( r(2) ) )
     &    * sin ( 2.0D+00 * pi * r(2) )

        saved = 1

        made = made + x_hi_index - x_lo_index + 2

      end if

      return
      end
      subroutine r8vec_print_part ( n, a, max_print, title )

c*********************************************************************72
c
cc R8VEC_PRINT_PART prints "part" of an R8VEC.
c
c  Discussion:
c
c    The user specifies MAX_PRINT, the maximum number of lines to print.
c
c    If N, the size of the vector, is no more than MAX_PRINT, then
c    the entire vector is printed, one entry per line.
c
c    Otherwise, if possible, the first MAX_PRINT-2 entries are printed,
c    followed by a line of periods suggesting an omission,
c    and the last entry.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    22 June 2010
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, integer N, the number of entries of the vector.
c
c    Input, double precision A(N), the vector to be printed.
c
c    Input, integer MAX_PRINT, the maximum number of lines to print.
c
c    Input, character*(*) TITLE, a title.
c
      implicit none

      integer n

      double precision a(n)
      integer i
      integer max_print
      character*(*) title

      if ( max_print .le. 0 ) then
        return
      end if

      if ( n .le. 0 ) then
        return
      end if

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

      if ( n .le. max_print ) then

        do i = 1, n
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

      else if ( 3 .le. max_print ) then

        do i = 1, max_print - 2
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

        write ( *, '(a)' ) '  ........  ..............'
        i = n

        write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)

      else

        do i = 1, max_print - 1
          write ( *, '(2x,i8,a1,1x,g14.6)' ) i, ':', a(i)
        end do

        i = max_print

        write ( *, '(2x,i8,a1,1x,g14.6,a)' )
     &    i, ':', a(i), '...more entries...'

      end if

      return
      end
      subroutine r8vec_uniform_01 ( n, seed, r )

c*********************************************************************72
c
cc R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    17 July 2006
c
c  Author:
c
c    John Burkardt
c
c  Reference:
c
c    Paul Bratley, Bennett Fox, Linus Schrage,
c    A Guide to Simulation,
c    Springer Verlag, pages 201-202, 1983.
c
c    Bennett Fox,
c    Algorithm 647:
c    Implementation and Relative Efficiency of Quasirandom
c    Sequence Generators,
c    ACM Transactions on Mathematical Software,
c    Volume 12, Number 4, pages 362-376, 1986.
c
c    Peter Lewis, Allen Goodman, James Miller,
c    A Pseudo-Random Number Generator for the System/360,
c    IBM Systems Journal,
c    Volume 8, pages 136-143, 1969.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input/output, integer SEED, the "seed" value, which should NOT be 0.
c    On output, SEED has been updated.
c
c    Output, double precision R(N), the vector of pseudorandom values.
c
      implicit none

      integer n

      integer i
      integer k
      integer seed
      double precision r(n)

      do i = 1, n

        k = seed / 127773

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

        if ( seed .lt. 0 ) then
          seed = seed + 2147483647
        end if

        r(i) = dble ( seed ) * 4.656612875D-10

      end do

      return
      end
      subroutine r8vec_write ( output_filename, n, x )

c*********************************************************************72
c
cc R8VEC_WRITE writes an R8VEC file.
c
c  Discussion:
c
c    An R8VEC is a vector of R8's.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    10 July 2011
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    Input, character * ( * ) OUTPUT_FILENAME, the output file name.
c
c    Input, integer N, the number of points.
c
c    Input, double precision X(N), the data.
c
      implicit none

      integer m
      integer n

      integer j
      character * ( * ) output_filename
      integer output_unit
      double precision x(n)
c
c  Open the file.
c
      call get_unit ( output_unit )

      open ( unit = output_unit, file = output_filename,
     &  status = 'replace' )
c
c  Create the format string.
c
      if ( 0 .lt. n ) then
c
c  Write the data.
c
        do j = 1, n
          write ( output_unit, '(2x,g24.16)' ) x(j)
        end do

      end if
c
c  Close the file.
c
      close ( unit = output_unit )

      return
      end
      subroutine timestamp ( )

c*********************************************************************72
c
cc TIMESTAMP prints out the current YMDHMS date as a timestamp.
c
c  Discussion:
c
c    This FORTRAN77 version is made available for cases where the
c    FORTRAN90 version cannot be used.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    12 January 2007
c
c  Author:
c
c    John Burkardt
c
c  Parameters:
c
c    None
c
      implicit none

      character * ( 8 ) ampm
      integer d
      character * ( 8 ) date
      integer h
      integer m
      integer mm
      character * ( 9 ) month(12)
      integer n
      integer s
      character * ( 10 ) time
      integer y

      save month

      data month /
     &  'January  ', 'February ', 'March    ', 'April    ',
     &  'May      ', 'June     ', 'July     ', 'August   ',
     &  'September', 'October  ', 'November ', 'December ' /

      call date_and_time ( date, time )

      read ( date, '(i4,i2,i2)' ) y, m, d
      read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm

      if ( h .lt. 12 ) then
        ampm = 'AM'
      else if ( h .eq. 12 ) then
        if ( n .eq. 0 .and. s .eq. 0 ) then
          ampm = 'Noon'
        else
          ampm = 'PM'
        end if
      else
        h = h - 12
        if ( h .lt. 12 ) then
          ampm = 'PM'
        else if ( h .eq. 12 ) then
          if ( n .eq. 0 .and. s .eq. 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, month(m), y, h, ':', n, ':', s, '.', mm, ampm

      return
      end


!C combine Fig_6.9_mandelbrotWrongPart2.f90 and Fig_6.8_mandelbrotWrongPart1.f90 into one file, and name it as mandel_wrong.f90
!C (notice part2 of mandel_wrong_module has to come before part1 of main program))
!C sample compile command: gfortran -fopenmp -o mandel_wrong mandel_wrong.f90

       PROGRAM mandel_wrong
       USE OMP_LIB
       USE mandel_module
       IMPLICIT NONE

       INTEGER :: i, j
       REAL(KIND = DP) :: area, error
       REAL(KIND = DP) :: eps = 1.0e-5

!C   Loop over grid of points in the complex plane which contains the Mandelbrot set,
!C   testing each point to see whether it is inside or outside the set.

!$OMP PARALLEL DO DEFAULT(shared) PRIVATE(c,eps)

       DO i = 1, NPOINTS
       DO j = 1, NPOINTS
          c%r = -2.0 + 2.5 * DBLE(i-1) / DBLE(NPOINTS) + eps
          c%i = 1.125 * DBLE(j-1) / DBLE(NPOINTS) + eps
          CALL testpoint()
       ENDDO
       ENDDO
!$OMP END PARALLEL DO

!C Calculate area of set and error estimate and output the results

       area = 2.0 * 2.5 *1.125 * DBLE(NPOINTS*NPOINTS - numoutside)   &
     &        /DBLE(NPOINTS*NPOINTS)
       error = area / DBLE(NPOINTS)

       PRINT *, "numoutside=", numoutside
       WRITE(*,100) area, error
100    FORMAT("Area of Mandlebrot set = ", f12.8, "  +/-", f12.8)
       PRINT *,"Correct answer should be around 1.510659"

       END PROGRAM mandel_wrong


PROGRAM SUMAR
  INTEGER :: N = 0
  INTEGER :: I
  INTEGER :: SUMA

  write (*,*) 'Capture el número: '
  read (*,*) N

  SUMA = 0

  DO I = 1, N
    SUMA = SUMA + I
  END DO

  WRITE(6, *) "Suma =", SUMA
END PROGRAM SUMAR


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: targ = 10001

  ! Variables
  integer(4) :: idx
  integer(8) :: i

  ! Do work
  idx = 0
  i   = 2
  do
     if (is_prime(i)) then
        idx = idx + 1
        if (idx==targ) exit
     endif
     i = i + 1
  enddo

  ! Write out answer
  write(*,*) "The prime with index ",targ,"is: ",i

contains

  pure function is_prime(targ)
    ! Default
    implicit none

    ! Function arguments
    integer(8), intent(in) :: targ
    logical                :: is_prime

    ! Local variables
    integer(8) :: i,max_try

    ! Find the max we should try
    max_try = int(sqrt(1D0*targ))

    do i=2,max_try
       if (mod(targ,i)==0) then
          is_prime = .false.
          return
       endif
    enddo

    is_prime = .true.
    return
  end function is_prime

end program main


module class_Circle
    implicit none
    private
    public :: Circle
    public :: circle_area
    public :: circle_print

    ! Class-wide private constant
    real :: pi = 3.1415926535897931d0

    type Circle
        real :: radius
    end type Circle

contains

    function circle_area(this) result(area)
        type(Circle), intent(in) :: this
        real                     :: area

        area = pi * this%radius**2

    end function circle_area

    subroutine circle_print(this)
        type(Circle), intent(in) :: this
        real                     :: area

        ! Call the circle_area function
        area = circle_area(this)

        print *, 'Circle'
        print *, '  r   = ', this%radius, &
                 ' area = ', area

    end subroutine circle_print

end module class_Circle


! Largest prime factor
! Problem 3
! The prime factors of 13195 are 5, 7, 13 and 29.
!
! What is the largest prime factor of the number 600851475143?

! Answer: 6857

program ex003
   implicit none

   integer(kind=8), parameter :: num = 600851475143_8
   integer, parameter :: sieve_size = floor(sqrt(real(num, 8)))
   integer :: res = 0

   print *, 'Sieve size:', sieve_size

   call each_prime(sieve_size, assign_prime_if_factor)

   print *, 'Answer:', res
contains
   subroutine each_prime(sieve_size, callback)
      implicit none

      integer, intent(in) :: sieve_size
      interface
         subroutine callback(arg)
            integer, intent(in) :: arg
         end subroutine callback
      end interface
      logical, dimension(:), allocatable :: sieve
      integer :: sqrt_sieve_size, i

      sqrt_sieve_size = floor(sqrt(real(sieve_size)))

      allocate(sieve(2:sieve_size))
      sieve(:) = .true.

      do i = 2, sieve_size
         if (sieve(i) .eqv. .true.) then
            if (i <= sqrt_sieve_size) sieve(i*i:sieve_size:i) = .false.

            call callback(i)
         end if
      end do

      deallocate(sieve)
   end subroutine each_prime

   subroutine assign_prime_if_factor(n)
      implicit none

      integer, intent(in) :: n

      if (mod(num, n) == 0) res = n
   end subroutine assign_prime_if_factor
end program ex003


      SUBROUTINE CNMN07 (II,XBAR,EPS,X1,Y1,X2,Y2,X3,Y3)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C     ROUTINE TO FIND FIRST XBAR.GE.EPS CORRESPONDING TO A REAL ZERO
C     OF A ONE-DIMENSIONAL FUNCTION BY POLYNOMIEL INTERPOLATION.
C     BY G. N. VANDERPLAATS                          APRIL, 1972.
C     NASA-AMES RESEARCH CENTER,  MOFFETT FIELD, CALIF.
C     II = CALCULATION CONTROL.
C          1:  2-POINT LINEAR INTERPOLATION, GIVEN X1, Y1, X2 AND Y2.
C          2:  3-POINT QUADRATIC INTERPOLATION, GIVEN X1, Y1, X2, Y2,
C              X3 AND Y3.
C     EPS MAY BE NEGATIVE.
C     IF REQUIRED ZERO ON Y DOES NOT EXITS, OR THE FUNCTION IS
C     ILL-CONDITIONED, XBAR = EPS-1.0 WILL BE RETURNED AS AN ERROR
C     INDICATOR.
C     IF DESIRED INTERPOLATION IS ILL-CONDITIONED, A LOWER ORDER
C     INTERPOLATION, CONSISTANT WITH INPUT DATA, WILL BE ATTEMPTED AND
C     II WILL BE CHANGED ACCORDINGLY.
      XBAR1=EPS-1.
      XBAR=XBAR1
      JJ=0
      X21=X2-X1
      IF (ABS(X21).LT.1.0E-20) RETURN
      IF (II.EQ.2) GO TO 30
C
10    CONTINUE
C     ------------------------------------------------------------------
C                  II=1: 2-POINT LINEAR INTERPOLATION
C     ------------------------------------------------------------------
      II=1
      YY=Y1*Y2
      IF (JJ.EQ.0.OR.YY.LT.0.) GO TO 20
C     INTERPOLATE BETWEEN X2 AND X3.
      DY=Y3-Y2
      IF (ABS(DY).LT.1.0E-20) GO TO 20
      XBAR=X2+Y2*(X2-X3)/DY
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
20    DY=Y2-Y1
C     INTERPOLATE BETWEEN X1 AND X2.
      IF (ABS(DY).LT.1.0E-20) RETURN
      XBAR=X1+Y1*(X1-X2)/DY
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
30    CONTINUE
C     ------------------------------------------------------------------
C                 II=2: 3-POINT QUADRATIC INTERPOLATION
C     ------------------------------------------------------------------
      JJ=1
      X31=X3-X1
      X32=X3-X2
      QQ=X21*X31*X32
      IF (ABS(QQ).LT.1.0E-20) RETURN
      AA=(Y1*X32-Y2*X31+Y3*X21)/QQ
      IF (ABS(AA).LT.1.0E-20) GO TO 10
      BB=(Y2-Y1)/X21-AA*(X1+X2)
      CC=Y1-X1*(AA*X1+BB)
      BAC=BB*BB-4.*AA*CC
      IF (BAC.LT.0.) GO TO 10
      BAC=SQRT(BAC)
      AA=.5/AA
      XBAR=AA*(BAC-BB)
      XB2=-AA*(BAC+BB)
      IF (XBAR.LT.EPS) XBAR=XB2
      IF (XB2.LT.XBAR.AND.XB2.GT.EPS) XBAR=XB2
      IF (XBAR.LT.EPS) XBAR=XBAR1
      RETURN
      END


      FUNCTION aspectratio()
      USE vmec_main
      USE realspace
      USE vmec_io
      IMPLICIT NONE
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: lk, l
      REAL(rprec) :: rb, zub, pi, t1, aspectratio
C-----------------------------------------------
!
!     routine for computing aspect-ratio (independent of elongation):
!     A = <R>/<ab>**.5
!
!     WHERE pi <a>**2 = Area (toroidally averaged)
!           2*pi * <R> * Area = Volume
!     Use integration by parts to compute as surface integral (Stoke''s theorem)
!

      pi = 4*ATAN(one)

!
!     Compute Volume and Mean (toroidally averaged) Cross Section Area
!
      volume_p = 0
      cross_area_p = 0
      DO lk = 1, nznt
         l = ns*lk
         rb  = r1(l,0) + r1(l,1)
         zub = zu(l,0) + zu(l,1)
         t1  = rb*zub*wint(l)
         volume_p = volume_p + rb*t1
         cross_area_p = cross_area_p + t1
      END DO

      volume_p = 2*pi*pi*ABS(volume_p)
      cross_area_p = 2*pi*ABS(cross_area_p)

      Rmajor_p = volume_p/(2*pi*cross_area_p)
      Aminor_p = SQRT(cross_area_p/pi)

      aspectratio = Rmajor_p/Aminor_p

      END FUNCTION aspectratio


module basic_stats_mod

    implicit none

contains

    !>-------------------------------------
    !! Compute the mean over the first dimension
    !!
    !! precondition: nt>0
    !!
    !!-------------------------------------
    subroutine time_mean(input, mean)
        implicit none
        real, intent(in),   dimension(:,:,:) :: input
        real, intent(inout),dimension(:,:)   :: mean

        integer :: nx, ny, nt
        integer :: x, y

        nt = size(input,1)
        nx = size(input,2)
        ny = size(input,3)

        do y=1,ny
            do x=1,nx
                mean(x,y) = sum(input(:,x,y)) / nt
            end do
        end do

    end subroutine time_mean

    !>-------------------------------------
    !! Compute the standard deviation over the first dimension
    !!
    !! precondition: nt>1
    !!
    !!-------------------------------------
    subroutine time_stddev(input, stddev, mean_in)
        implicit none
        real, intent(in),    dimension(:,:,:) :: input
        real, intent(inout), dimension(:,:)   :: stddev
        real, intent(in),    dimension(:,:),  optional :: mean_in
        real, dimension(:,:), allocatable :: mean

        integer :: nx, ny, nt
        integer :: x, y

        nt = size(input,1)
        nx = size(input,2)
        ny = size(input,3)

        ! There are one pass stddev algorithms, this is clear and provides a nice option to use an existing mean
        allocate(mean(nx,ny))
        if (.not.present(mean_in)) then
            call time_mean(input,mean)
        else
            mean = mean_in
        endif

        ! note, for nt==1, stddev is undefined.  Here return the 10x the mean just to show it is BIG
        if (nt<=1) then
            stddev = abs(mean) * 10
            write(*,*) "WARNING: attempting to compute a standard deviation of one value!", shape(input)
            return
        endif

        do y=1,ny
            do x=1,nx
                stddev(x,y) = sqrt( sum( (input(:,x,y) - mean(x,y))**2 ) / (nt-1) )
            end do
        end do

    end subroutine time_stddev

    function stddev(input, mean_in)
        implicit none
        real, dimension(:) :: input
        real, intent(in), optional :: mean_in
        real :: stddev

        real :: mean
        integer :: x, n

        n = size(input)

        if (present(mean_in)) then
            mean = mean_in
        else
            mean = sum(input) / n
        endif

        stddev = sqrt( sum( (input - mean)**2 ) / (n-1) )

    end function stddev

end module basic_stats_mod


      function func(x)
      real*8::x,func
        func= x*exp(x)
      end

      program  aa

!      subroutine prder(x,func,n,h,D)
      !primera derivada de orden n en el error, en el intervalo h

      implicit none
      external func
      real*8::h,x
      real*8::func
      REAL*8,ALLOCATABLE,DIMENSION(:,:)::D
      integer*4::i,j,n
       x=2.
       n=4
       h=4d-1
      allocate(D(n,n))
      D(:,:)=0.0d1
      !CADA fila es un D(fila ejemplo 1) con la primer cordenada 2H la segunda H la tercera H/2. la segunda fila es un D2 con primer elemento H segundo H/2 Y ASI

      do j=0,n-1
      do i=1,n-j

      if (j==0) then
      if (i==1) then
      D(j+1,i)=((func(x+h)-func(x-h))/(2*h))
      print*, j+1,i, D(j+1,i), 'a'
      else
      D(j+1,i)=((func(x+(h/(2**(i-1))))-func(x-(h/(2**(i-1)))))/(2*(h/(2**(i-1)))))
      print*, j+1,i, D(j+1,i), 'b'
      end if
      else
      D(j+1,i)=(((2**(2*(j))))*D(j,i+1)-D(j,i))/((2**(2*(j)))-1)
      print*, j+1,i, D(j+1,i), 'c'

      end if
      end do

      end do

      print*, ' '
      print*,'el valor de h usado es', h
      print*, ' '
      print*,'el valor de x usado es', x
      print*, ' '
      print*, 'de la funcion ', ' f(x) = exp(x)*x'
      print*, ' '

      print*, 'la matriz D es '

      do i=1,n
      print*, D(:,i)
      end do
      print*, ' '

      print*, 'el valor final con presicion',n, 'es', D(n,1)

      print*, 'el valor de la derivada analitica es ', (exp(2.)*3)

      return
      end


PROGRAM MAIN

  IMPLICIT NONE

  INTEGER :: i, sgn
  INTEGER, PARAMETER :: max_iter = 100
  REAL :: term, sin_approx, x

  x = 3.14159/ 8.0 ! Pi/16

  ! Keep a running sign for simplicity
  sgn = -1

  !I compute the first term explicitly here:
  term = x
  sin_approx = term

  ! Only need odd numbered terms so use loop stride for clarity
  DO i = 3, max_iter, 2
    ! A sneaky way to do less computation. Each term adds another factor of x**2 and
    ! 2 contributions to the factorial.
    ! I do not store factorial. Also I do the type conversions explicitly
    ! NB : turning an integer into a real CAN change its value. Doing it for i or even i*(i-1)
    ! will be fine for these values, but for an entire n! can change. But that only
    ! gives us a fractional error
    term = sgn * term * x**2 / REAL(i)/ REAL(i-1)

    sin_approx = sin_approx + term

    sgn = -1 * sgn

  END DO

  PRINT*, "An approximation to sin(x) for x=", x, " is: ", sin_approx

END PROGRAM


      real*8 function dstn1(rn1,rn2) result (r_dstn1)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this function computes the distance from the mean of a normal
!!    distribution with mean = 0 and standard deviation = 1, given two
!!    random numbers

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name       |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    rn1        |none          |first random number
!!    rn2        |none          |second random number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name       |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    dstn1      |              |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt, Log, Cos

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      real*8, intent (in) :: rn1, rn2

      r_dstn1 = 0.
      r_dstn1 = Sqrt(-2. * Log(rn1)) * Cos(6.283185 * rn2)

      return
      end


      SUBROUTINE qromb(func,a,b,ss)
      INTEGER JMAX,JMAXP,K,KM
      REAL a,b,func,ss,EPS
      EXTERNAL func
      PARAMETER (EPS=1.e-6, JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1)
CU    USES polint,trapzd
      INTEGER j
      REAL dss,h(JMAXP),s(JMAXP)
      h(1)=1.
      do 11 j=1,JMAX
        call trapzd(func,a,b,s(j),j)
        if (j.ge.K) then
          call polint(h(j-KM),s(j-KM),K,0.,ss,dss)
          if (abs(dss).le.EPS*abs(ss)) return
        endif
        s(j+1)=s(j)
        h(j+1)=0.25*h(j)
11    continue
      pause 'too many steps in qromb'
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/qromb.for


c=======================================================================
c
c     subroutine KATP
c
c     Kato decomposition of a symmetric matrix with positive eigenvalues
c     (eigenvalues  > eps kato )
c
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : input matrix (n*n)                          double
c            epskat : Kato sensibility                            double
c
c     WORKSPACE
c            iwork  : vector ( 12*n )                            integer
c            dwork  : matrix ( n*(2*n+26) )                       double
c
c     OUTPUT
c            eigval : eigenvalues vector (n)                      double
c            soreig : sorted eigenvalues (n)                      double
c            vpmat  : ordered eigenvectors (n*n)                  double
c            nbkgrp : number of Kato groups                      integer
c            grpkat : Kato groups (n) output size (nbkgrp)       integer
c            info   : diagnostic argument                        integer
c
c     CALL
c            SCHURSO : SCHUR decomposition of a symmetric matrix
c                      sorts eigenvalues and eigenvectors (decrease order)
c            GREPS   : computes groups for a sensibility epsilon
c
c     METHOD
c            for Kato groups vector
c            for an example of eigenvalues vector ( size = 7 ) :
c            eigval = [ 5.2, 5.1, 3.5, 3.4, 3.3, 1.7 1.3 ]
c            and epskat = 0.15, the routine computes
c            nbkgrp = 4
c            grpvec = [ 2, 3, 1, 1 ]
c
c-----------------------------------------------------------------------
c
      SUBROUTINE katp ( n, X, epskat, iwork, dwork,
     &                  eigval, soreig, vpmat, nbkgrp, grpkat, info )
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, nbkgrp, info
      INTEGER grpkat(*)
      DOUBLE PRECISION epskat
      DOUBLE PRECISION eigval(*), soreig(*), X(*), vpmat(n,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i
c
c     external subroutines
      EXTERNAL schurso, greps
c
c     intrinsic functions
      INTRINSIC MAX
c
c-----------------------------------------------------------------------
c
c     SCHUR decomposition of a symmetric matrix
c     sorts eigenvalues and eigenvectors (decrease order)
      CALL schurso ( n, X, iwork, dwork,
     &               eigval, soreig, vpmat, info )
      IF (info .LT. 0) RETURN
c
c     up eigenvalues to epskat
      DO i=1,n
         soreig(i) = MAX( epskat , soreig(i) )
      ENDDO
c
c     computes Kato groups for a sensibility epsilon
      CALL greps ( n, soreig, epskat, nbkgrp, grpkat, info )
c
      RETURN
      END


!********************************************************************************
!   NEWTON_LIMITACC: Test limiting accuracy of compensated Newton's method
!   Authors: Thomas R. Cameron and Aidan O'Neill
!   Institution: Davidson College, Mathematics and Computer Science Department
!   Last Modified: 22 March 2019
!********************************************************************************
program newton_limitAcc
    use eft
    use mproutines
    implicit none
    ! parameters
    integer, parameter              :: itnum = 5
    ! polynomial variables
    integer                         :: deg
    real(kind=dp)                   :: x
    complex(kind=dp)                :: z
    real(kind=dp), allocatable      :: poly(:)
    complex(kind=dp), allocatable   :: cpoly(:)
    ! testing variables
    real(kind=dp)                   :: bound, error, compBound, compError, cond, exact, g
    complex(kind=dp)                :: cexact

    ! random seed
    call init_random_seed()
    ! open real test file
    open(unit=1,file="data_files/newton_limitAcc_real.dat")
    write(1,'(A)') 'cond, stan_err_bound, stan_err, comp_err_bound, comp_err'
    ! run real test
    do deg=1,40
        ! allocate polynomial variable
        allocate(poly(deg+1))
        ! polynomial
        call limAccPoly(poly,deg)
        ! exact root
        exact = limAccRoot(poly,deg)
        ! condition number and error bounds
        g = 2*deg*mu/(1-2*deg*mu)
        cond = compCond(poly,exact,deg)
        bound = cond*g
        compBound = mu + cond*g**2
        if(bound>1.0_dp) bound = 1.0_dp
        if(compBound>1.0_dp) compBound = 1.0_dp
        ! standard Newton's method
        x = exact + exact*compBound
        call SNewton(poly,x,deg)
        error = abs(x - exact)/abs(exact)
        if(error<mu) then
            error = mu
        else if(error>1.0_dp) then
            error = 1.0_dp
        end if
        ! compensated Newton's method
        x = exact + exact*compBound
        call CNewton(poly,x,deg)
        compError = abs(x - exact)/abs(exact)
        if(compError<mu) then
            compError = mu
        else if(compError>1.0_dp) then
            compError = 1.0_dp
        end if
        ! deallocate polynomial
        deallocate(poly)
        ! write to file
        write(1,'(ES15.2)', advance='no') cond
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') bound
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') error
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') compBound
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)') compError
    end do
    ! close real test file
    close(1)

    ! open complex test file
    open(unit=1,file="data_files/newton_limitAcc_cmplx.dat")
    write(1,'(A)') 'cond, stan_err_bound, stan_err, comp_err_bound, comp_err'
    ! run complex text
    do deg=1,40
        ! allocate polynomial variable
        allocate(cpoly(deg+1))
        ! polynomial
        call limAccPolyCplx(cpoly,deg)
        ! exact root
        cexact = limAccRootCplx(cpoly,deg)
        ! condition number and error bounds
        g = 2*mu/(1-2*mu)
        g = 2*deg*sqrt(2.0_dp)*g/(1-2*deg*sqrt(2.0_dp)*g)
        cond = compCondCplx(cpoly,cexact,deg)
        bound = cond*g
        compBound = mu + cond*g**2
        if(bound>1.0_dp) bound = 1.0_dp
        if(compBound>1.0_dp) compBound = 1.0_dp
        ! standard Newton's method
        z = cexact + cexact*compBound
        call SNewtonCplx(cpoly,z,deg)
        error = abs(z - cexact)/abs(cexact)
        if(error<mu) then
            error = mu
        else if(error>1.0_dp) then
            error = 1.0_dp
        end if
        ! compensated Newton's method
        z = cexact + cexact*compBound
        call CNewtonCplx(cpoly,z,deg)
        compError = abs(z - cexact)/abs(cexact)
        if(compError<mu) then
            compError = mu
        else if(compError>1.0_dp) then
            compError = 1.0_dp
        end if
        ! deallocate polynomial
        deallocate(cpoly)
        ! write to file
        write(1,'(ES15.2)', advance='no') cond
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') bound
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') error
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)', advance='no') compBound
        write(1,'(A)', advance='no') ','
        write(1,'(ES15.2)') compError
    end do
    ! close complex test file
    close(1)
contains
    !************************************************
    !                   init_random_seed            *
    !************************************************
    ! Initiate random seed using system_clock. This
    ! seed is then available for the random number
    ! generator in random_number for the life of
    ! the program.
    !************************************************
    subroutine init_random_seed()
        implicit none
        ! local variables
        integer                             :: i, n, clock
        integer, dimension(:), allocatable  :: seed
        ! intrinsic subroutines
        intrinsic                           :: random_seed, system_clock

        ! main
        call random_seed(size = n)
        allocate(seed(n))

        call system_clock(count = clock)
        seed = clock + 37 * (/ (i - 1, i = 1,n) /)
        call random_seed(put = seed)

        deallocate(seed)
    end subroutine init_random_seed
    !********************************************************
    !                   Standard Newton                     *
    !********************************************************
    ! Computes a root approximation of a polynomial using
    ! standard Newton's method in dp-precision. The result
    ! is stored in x.
    !********************************************************
    subroutine SNewton(poly,x,deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        real(kind=dp), intent(in)       :: poly(:)
        real(kind=dp), intent(inout)    :: x
        ! local variables
        integer                         :: j, k
        real(kind=dp)                   :: alpha, beta

        ! Newton's method
        do k=1,itnum
            ! compute alpha and beta
            alpha = poly(deg+1)
            beta = 0.0_dp
            do j=deg,1,-1
                beta = x*beta + alpha
                alpha = x*alpha + poly(j)
            end do
            ! update x
            x = x - (alpha/beta)
        end do
    end subroutine SNewton
    !********************************************************
    !                   Standard Newton Cplx                *
    !********************************************************
    ! Complex version of Standard Newton.
    !********************************************************
    subroutine SNewtonCplx(poly,x,deg)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: poly(:)
        complex(kind=dp), intent(inout) :: x
        ! local variables
        integer                         :: j, k
        complex(kind=dp)                :: alpha, beta

        ! Newton's method
        do k=1,itnum
            ! compute alpha and beta
            alpha = poly(deg+1)
            beta = cmplx(0.0_dp,0.0_dp,kind=dp)
            do j=deg,1,-1
                beta = x*beta + alpha
                alpha = x*alpha + poly(j)
            end do
            ! update x
            x = x - (alpha/beta)
        end do
    end subroutine SNewtonCplx
    !********************************************************
    !                   Compensated Newton                  *
    !********************************************************
    ! Computes a root approximation of a polynomial using
    ! compensated Newton's method in dp-precision, i.e.,
    ! the polynomial evaluation is done using a compensated
    ! Horner's method. The result is stored in x.
    !********************************************************
    subroutine CNewton(poly,x,deg)
        ! argument variables
        integer, intent(in)             :: deg
        real(kind=dp), intent(in)       :: poly(:)
        real(kind=dp), intent(inout)    :: x
        ! local variables
        integer                         :: j, k
        real(kind=dp)                   :: alpha, alphaErr, beta, betaErr
        type(REFT)                      :: prod, sum

        ! Newton's method
        do k=1,itnum
            ! compute alpha and beta
            alpha = poly(deg+1)
            alphaErr = 0.0_dp
            beta = 0.0_dp
            betaErr = 0.0_dp
            do j=deg,1,-1
                ! product and sum for beta
                prod = TwoProduct(beta,x)
                sum = TwoSum(prod%x,alpha)
                ! update beta and betaErr
                beta = sum%x
                betaErr = x*betaErr + alphaErr + (prod%y + sum%y)
                ! product and sum for alpha
                prod = TwoProduct(alpha,x)
                sum = TwoSum(prod%x,poly(j))
                ! update alpha and alphaErr
                alpha = sum%x
                alphaErr = x*alphaErr + (prod%y + sum%y)
            end do
            ! add error back into result
            beta = beta + betaErr
            alpha = alpha + alphaErr
            ! update x
            x = x - (alpha/beta)
        end do
    end subroutine CNewton
    !********************************************************
    !                   Compensated Newton Cplx             *
    !********************************************************
    ! Complex version of Compensated Newton.
    !********************************************************
    subroutine CNewtonCplx(poly,x,deg)
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: poly(:)
        complex(kind=dp), intent(inout) :: x
        ! local variables
        integer                         :: j, k
        complex(kind=dp)                :: alpha, alphaErr, beta, betaErr
        type(CEFTSum)                   :: sum
        type(CEFTProd)                  :: prod

        ! Newton's method
        do k=1,itnum
            ! compute alpha and beta
            alpha = poly(deg+1)
            alphaErr = cmplx(0.0_dp,0.0_dp,kind=dp)
            beta = cmplx(0.0_dp,0.0_dp,kind=dp)
            betaErr = cmplx(0.0_dp,0.0_dp,kind=dp)
            do j=deg,1,-1
                ! product and sum for beta
                prod = TwoProductCplx(beta,x)
                sum = TwoSumCplx(prod%p,alpha)
                ! update beta and betaErr
                beta = sum%x
                betaErr = x*betaErr + alphaErr + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
                ! product and sum for alpha
                prod = TwoProductCplx(alpha,x)
                sum = TwoSumCplx(prod%p,poly(j))
                ! update alpha and alphaErr
                alpha = sum%x
                alphaErr = x*alphaErr + FaithSumCplx(prod%e,prod%f,prod%g,sum%y)
            end do
            ! add error back into result
            beta = beta + betaErr
            alpha = alpha + alphaErr
            ! update x
            x = x - (alpha/beta)
        end do
    end subroutine CNewtonCplx
end program newton_limitAcc


subroutine elmder(nnode,ndime,deriv,elcod,cartd,detjm,xjacm,xjaci)
!-----------------------------------------------------------------------
! NAME
!    elmder
! DESCRIPTION
!    This routine calculates the Cartesian derivatives cartd and detjm.
! USES
!    invmtx
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: nnode,ndime
  real(rp),    intent(in)  :: deriv(ndime,nnode),elcod(ndime,nnode)
  real(rp),    intent(out) :: detjm,cartd(ndime,nnode)
  real(rp),    intent(out) :: xjacm(ndime,ndime)
  real(rp),    intent(out) :: xjaci(ndime,ndime)

  xjacm=matmul(elcod,transpose(deriv))
  call invmtx(xjacm,xjaci,detjm,ndime)
  cartd=matmul(transpose(xjaci),deriv)

end subroutine elmder
!-----------------------------------------------------------------------
! NOTES
! Try to remember... when life was so tender...
!        _        _           _                    _
!       | x1 x2 x3 |         | dN1/ds dN2/ds dN3/ds |
! elcod=|          |,  deriv=|                      |
!       |_y1 y2 y3_|         |_dN1/dt dN2/dt dN3/dt_|
!        _           _
!       | dx/ds dx/dt |            t
! xjacm=|             |=elcod*deriv
!       |_dy/ds dy/dt_|
!        _           _
!       | ds/dx ds/dy |      -1
! xjaci=|             |=xjacm  .This is because:
!       |_dt/dx dt/dy_|
!        _     _   _           _   _     _
!       | du/dx | | ds/dx dt/dx | | du/ds |
!       |       |=|             | |       | and
!       |_du/dy_| |_ds/dy dt/dy_| |_du/dt_|
!        _     _   _           _   _     _      _     _   _           _ -1  _     _
!       | du/ds | | dx/ds dy/ds | | du/dx |    | du/dx | | dx/ds dy/ds |   | du/ds |
!       |       |=|             | |       | => |       |=|             |   |       |
!       |_du/dt_| |_dx/dt dy/dt_| |_du/dy_|    |_du/dy_| |_dx/dt dy/dt_|   |_du/dt_|
!                  _           _   _           _ -1
!                 | ds/dx dt/dx | | dx/ds dy/ds |      -1
!       Therefore |             |=|             |=xjacm
!                 |_ds/dy dt/dy_| |_dx/dt dy/dt_|
!        _                                                                               _
!       | dN1/ds*ds/dx+dN1/dt*dt/dx  dN2/ds*ds/dx+dN2/dt*dt/dx dN3/ds*ds/dx+dN3/dt*dt/dx  |
! cartd=|                                                                                |
!       |_dN1/ds*ds/dy+dN1/dt*dt/dy  dN2/ds*ds/dy+dN2/dt*dt/dy dN3/ds*ds/dy+dN3/dt*dt/dy _|
!            t
!      =xjaci *deriv
!           _     _
!          | du/dx |                 t
! Example: |       |=cartd*[U1 U2 U3]
!          |_du/dy_|
!
!***
!-----------------------------------------------------------------------


	FUNCTION PR_INMM  ( xinch )
C************************************************************************
C* PR_INMM								*
C*									*
C* This function converts inches to millimeters.  The following		*
C* equation is used:							*
C*									*
C*           INMM = XINCH * 25.4					*
C*									*
C* REAL PR_INMM ( XINCH )						*
C*									*
C* Input parameters:							*
C*	XINCH		REAL		Inches		 		*
C*									*
C* Output parameters:							*
C*	PR_INMM		REAL		Millimeters		        *
C**									*
C* Log:									*
C* S. Schotz/GSC	10/89	Original source				*
C* K. Brill/NMC		01/92	Convert inches rather than 1/100 inches *
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C-----------------------------------------------------------------------
C*	Check for missing value.
C
	IF  ( ERMISS ( xinch ) )  THEN
	    PR_INMM = RMISSD
	  ELSE
C
C*	    Inches to millimeters
C
            PR_INMM = xinch * 25.4
	END IF
C*
	RETURN
	END