module greedy_coins_mod
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none

    private

    public :: nr_change_coins, change_coins

contains

    function nr_change_coins(amount, coins) result(nr_coins)
        implicit none
        integer, value :: amount
        integer, dimension(:), intent(in) :: coins
        integer :: nr_coins
        integer :: coin_nr, coin

        nr_coins = 0
        do coin_nr = size(coins), 1, -1
            coin = coins(coin_nr)
            nr_coins = nr_coins + amount/coin
            amount = mod(amount, coin)
        end do
    end function nr_change_coins

    function change_coins(amount, coins) result(change)
        implicit none
        integer, value :: amount
        integer, dimension(:), intent(in) :: coins
        integer, dimension(:), allocatable :: change
        integer :: status, coin_nr, coin

        allocate (change(size(coins)), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A)') 'error: can not allocate change'
            stop 1
        end if
        do coin_nr = size(coins), 1, -1
            coin = coins(coin_nr)
            change(coin_nr) = amount/coin
            amount = mod(amount, coin)
        end do
    end function change_coins

end module greedy_coins_mod


module mod
  contains
  function add(x, y)
    real :: x
    real :: y
    real  :: add(10)
    integer :: i
    do i = 1, 10
      add(i) = x + y
    end do
  end function add
end module mod

program t
  use mod
  real :: r(10)
  r = add(10.55, 5.1010)
  print *, r

end program t


    Program ztrexc_example

!     ZTREXC Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: ztrexc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, ifst, ilst, info, ldq, ldt, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: q(:, :), t(:, :)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZTREXC Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldq = 1
      ldt = n
      Allocate (q(ldq,1), t(ldt,n))

!     Read T from data file

      Read (nin, *)(t(i,1:n), i=1, n)

!     Read the row indices

      Read (nin, *) ifst, ilst

!     Reorder the Schur factor T

      Call ztrexc('No update', n, t, ldt, q, ldq, ifst, ilst, info)
      If (info/=0) Then
        Write (nout, 100) info, ilst
        Write (nout, *)
        Flush (nout)
      End If

!     Print reordered Schur form

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, t, &
        ldt, 'Bracketed', 'F7.4', 'Reordered Schur form', 'Integer', rlabs, &
        'Integer', clabs, 80, 0, ifail)

100   Format (' Reordering could not be completed. INFO = ', I3, ' ILST = ', &
        I5)
    End Program


program taupTC_text

IMPLICIT NONE
INTEGER                       :: status_read, ipts, npts
REAL(kind=8)                  :: DD, TT, ref_distance, ref_time1, ref_time2, timeAT_ref_distance
REAL(kind=8),ALLOCATABLE      :: distance(:), time(:)
CHARACTER*80                  :: TC_file, temptext

   READ(*,*) TC_file
   READ(*,*) ref_distance
   READ(*,*) ref_time1, ref_time2

   status_read = 0
   ipts = 0
   open(11, file = TC_file)
   read(11,*) temptext
   do while ( status_read .eq. 0 )
      read(11,*, iostat= status_read ) DD, TT
      ipts = ipts+1
   end do
   npts = ipts - 1
   rewind(11)
   ALLOCATE ( distance(npts), time(npts))
   read(11,*) temptext
   do ipts = 1, npts
     read(11,*) distance(ipts), time(ipts)
   end do

   do ipts = 1, npts-1
       if (  (distance(ipts) <= ref_distance .and.  ref_distance <= distance(ipts+1))  .or. &
             (distance(ipts+1) <= ref_distance .and.  ref_distance <= distance(ipts)) ) then
            call LinerINTP( distance(ipts), time(ipts) , distance(ipts+1), time(ipts+1), ref_distance, timeAT_ref_distance )
            if ( timeAT_ref_distance >= ref_time1 .and. timeAT_ref_distance <= ref_time2 ) then
               print *, ref_distance, timeAT_ref_distance
            end if
       end if

   end do

STOP
END

SUBROUTINE LinerINTP(x1,y1,x2,y2,xx,yy)

real(kind=8)  :: x1,y1,x2,y2,xx,yy
real(kind=8)  :: slope

slope = (y2-y1)/(x2-x1)

yy=slope*xx+y1-slope*x1

return
end


!Data and Where
program Data_Where
    implicit none

    INTEGER, DIMENSION(5):: array_one_d
    INTEGER, DIMENSION(4, 4):: array_two_d
    INTEGER :: i, j

    data array_one_d/1, 2, 3, 4, 5/

    data array_two_d(1, :)/1, 2, 3, 4/
    data array_two_d(2, :)/5, 6, 7, 8/
    data array_two_d(3, :)/9, 10, 11, 12/
    data array_two_d(4, :)/13, 14, 15, 16/

    !Note:
    ! array_two_d(1,:)

    ! before comma represent rows and after comma represent columns
    ! 1, --> first row
    ! : --> all collumns
    ! array_two_d(1,:) --> one row ko all column

    ! Similarly,
    ! array_two_d(2,:) --> second row ko all column

    !Array one Dimension
    print *, "One Dimension"
    do i = 1, 5
        print *, array_one_d(i)
    end do

    !Array two Dimension
    print *, "Two Dimension"
    do i = 1, 4
        print *, (array_two_d(i, j), j=1, 4)
    end do

    !where is just used to compare all value of matrix at once

    where (array_two_d < 10)
        array_two_d = 0
    else where
        array_two_d = 1
    end where

    print *, "Result after comparing all value of matrix with 10"

    do i = 1, 4
        print *, (array_two_d(i, j), j=1, 4)
    end do

    print *, "0 mean less than 10 and 1 mean greater than or equal to 10"

end program Data_Where


module init_phi_module

  use boxlib_module

  implicit none

  private

  public :: init_phi

contains

  subroutine init_phi(phi,geom)

    type(multifab), intent(inout) :: phi
    type(geometry), intent(in   ) :: geom

    ! local variables
    integer :: lo(4), hi(4)
    type(Box) :: bx
    type(mfiter) :: mfi
    double precision, pointer :: p(:,:,:,:)

    !$omp parallel private(bx,p,lo,hi)
    call mfiter_build(mfi, phi, tiling=.true.)
    do while(mfi%next())
       bx = mfi%tilebox()
       p => phi%dataPtr(mfi)
       lo = lbound(p)
       hi = ubound(p)
       select case (bl_num_dims)
       case (2)
          call init_phi_2d(bx%lo(1:2), bx%hi(1:2), p(:,:,1,1), lo(1:2), hi(1:2), &
               geom%problo(1:2), geom%dx(1:2))
       case (3)
          call init_phi_3d(bx%lo, bx%hi, p(:,:,:,1), lo(1:3), hi(1:3), &
               geom%problo, geom%dx)
       end select
    end do
    !$omp end parallel

  end subroutine init_phi

  subroutine init_phi_2d(lo, hi, phi, dlo, dhi, prob_lo, dx)
    integer          :: lo(2), hi(2), dlo(2), dhi(2)
    double precision :: phi(dlo(1):dhi(1),dlo(2):dhi(2))
    double precision :: prob_lo(2)
    double precision :: dx(2)

    ! local varables
    integer          :: i,j
    double precision :: x,y,r2

    do j=lo(2),hi(2)
       y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
       do i=lo(1),hi(1)
          x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

          r2 = ((x-0.25d0)**2 + (y-0.25d0)**2) / 0.01d0
          phi(i,j) = 1.d0 + exp(-r2)

       end do
    end do

  end subroutine init_phi_2d

  subroutine init_phi_3d(lo, hi, phi, dlo, dhi, prob_lo, dx)
    integer          :: lo(3), hi(3), dlo(3), dhi(3)
    double precision :: phi(dlo(1):dhi(1),dlo(2):dhi(2),dlo(3):dhi(3))
    double precision :: prob_lo(3)
    double precision :: dx(3)

    ! local varables
    integer          :: i,j,k
    double precision :: x,y,z,r2

    do k=lo(3),hi(3)
       z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
       do j=lo(2),hi(2)
          y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
          do i=lo(1),hi(1)
             x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

             r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) / 0.01d0
             phi(i,j,k) = 1.d0 + exp(-r2)

          end do
       end do
    end do

  end subroutine init_phi_3d

end module init_phi_module


      SUBROUTINE SHTRNS(L3D,LV,ITYPE,X,SCOEF)
C
C THIS SUBROUTINE PERFORMS SPHERICAL HARMONIC TRANSFORMS AND INVERSE
C TRANFORMS OF ARBITRARY SCALAR DATA USING THE GAUSSIAN GRID (SEE
C THE GUASSIAN LATITUDES AND WEIGHTS) AND THE ASSOCIATED LEGENDRE
C POLYNOMIALS AND DERIVATIVES SPECIFIED IN COMMON BLOCK TRNSFM.
C IT USES THE LIBRARY ROUTINE FFT991 FOR IN-PLACE FAST FOURIER
C TRANSFORMS.
C
C CALLED BY: COMP1, INIT, STSWM
C CALLS: FFT991
C
C REVISIONS:
C 7-13-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C WORKSPACE
      INCLUDE 'wrkspc.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C NUMBER OF TIME LEVELS OF X
      INTEGER L3D
C CURRENT TIME LEVEL FOR FIELD X
      INTEGER LV
C SPECIFIES TYPE OF TRANSFORM DESIRED
C          -1 => FORWARD TRANSFORM X -> SCOEF
C          +1 => INVERSE TRANSFORM SCOEF -> X
      INTEGER ITYPE
C
C     Input/Output
C
C SCALAR DATA (ON GAUSSIAN GRID)
      REAL X(NLON+2,NLAT,L3D)
C SPHERICAL HARMONIC COEFFICIENT ARRAY
      COMPLEX SCOEF(NALP)
C
C------ Local Variables ------------------------------------------------
C
C     EQUIVALENCE TO WORKSPACE IN STORAGE POOL /WRKSPC/, ETC.
C
      COMPLEX   CEVEN(NLAT/2,NFC), CODD (NLAT/2,NFC)
      EQUIVALENCE (CEVEN(1,1),WS4(1,1)), (CODD(1,1),WS4(1,NLAT/2+1))
C
      COMPLEX   CTMP1(MM+1), CTMP2(MM+1)
C
C     TEMPORARIES
C
      INTEGER NL, JM, JN, IS, SL
C
C----- Executable Statements -------------------------------------------
C
C     FIRST CHECK FOR VALID ARGUMENTS; INVALID ARGUMENTS=>FATAL ERROR
C
      IF ((ITYPE .NE. +1) .AND. (ITYPE .NE. -1)) THEN
         WRITE (0,900) ITYPE
  900    FORMAT(/,' STSWM: FATAL ERROR IN SUBROUTINE SHTRNS:',/,
     $            ' UNKNOWN TYPE OF TRANSFORM SPECIFIED',/,
     $          ' ITYPE = ',I3)
         STOP
      ENDIF
C
      IF (ITYPE .EQ. -1) THEN
C
C     FORWARD TRANSFORM FROM PHYSICAL TO WAVENUMBER SPACE (ITYPE=-1)
C
C     IN PLACE FFT FOR ALL LATITUDES OF TIMELEVEL LV
C
         CALL FFT991(X(1,1,LV),FFTWS2,TRIGS,IFAX,1,NLON+2,
     $                  NLON,NLAT,-1)
C
C        PROCEDURE FOR FORWARD GAUSS-LEGENDRE TRANSFORM.
C        VARY M AND N SO THAT PROCEDURE MOVES ALONG DIAGONALS DENOTED
C        BY INDEX JN.  M IS GIVEN BY (JM-1) WHILE N IS GIVEN BY (JN+M).
C        SINCE NUMBER OF GAUSSIAN LATITUDES IS EVEN, TAKE ADVANTAGE OF
C        THE SYMMETRIC CHARACTER OF THE ASSOCIATED LEGENDRE POLYNOMIALS
C
         DO 100 NL=1,NLAT/2
            SL = NLAT-NL+1
C
            DO 30 JM=1,MM+1
C              CTMP1(JM) = (X(JM,NL,LV) + X(JM,SL,LV))*WTS(NL)
               CTMP1(JM) = (CMPLX(X(2*JM-1,NL,LV),X(2*JM,NL,LV)) +
     $            CMPLX(X(2*JM-1,SL,LV),X(2*JM,SL,LV)))
     $            * WTS(NL)
C              CTMP2(JM) = (X(JM,NL,LV) - X(JM,SL,LV))*WTS(NL)
               CTMP2(JM) = (CMPLX(X(2*JM-1,NL,LV),X(2*JM,NL,LV)) -
     $            CMPLX(X(2*JM-1,SL,LV),X(2*JM,SL,LV)))
     $            * WTS(NL)

   30       CONTINUE
C
C           SPECIAL HANDLING OF THE FIRST LATITUDE IN THE ACCUMULATION
C           THIS DETOUR ELIMINATES THE NEED TO SEPARATELY ZERO SCOEF
C
            IF (NL .EQ. 1) THEN
C
C           EVEN WAVENUMBERS FIRST
C
               DO 50 JN=0,NN,2
                  IS = LDIAG(JN,2)
C
                  DO 45 JM=1,LDIAG(JN,1)
                     SCOEF(IS+JM) = CTMP1(JM)*ALP(IS+JM,NL)
   45             CONTINUE
   50          CONTINUE
C
C           ODD WAVENUMBERS NEXT
C
               DO 60 JN=1,NN,2
                  IS = LDIAG(JN,2)
C
                  DO 55 JM=1,LDIAG(JN,1)
                     SCOEF(IS+JM) = CTMP2(JM)*ALP(IS+JM,NL)
   55             CONTINUE
   60          CONTINUE
            ELSE
C
C           REMAINING LATITUDES CONTRIBUTING TO SUM
C           EVEN WAVENUMBERS
C
            DO 75 JN=0,NN,2
               IS = LDIAG(JN,2)
C
               DO 70 JM=1,LDIAG(JN,1)
                  SCOEF(IS+JM) = SCOEF(IS+JM) +
     $                              CTMP1(JM)*ALP(IS+JM,NL)
   70          CONTINUE
   75       CONTINUE
C
C           ODD WAVENUMBERS
C
            DO 90 JN=1,NN,2
               IS = LDIAG(JN,2)
C
               DO 80 JM=1,LDIAG(JN,1)
                  SCOEF(IS+JM) = SCOEF(IS+JM) +
     $                              CTMP2(JM)*ALP(IS+JM,NL)
   80          CONTINUE
   90       CONTINUE
C
            ENDIF
  100    CONTINUE
C
C        TRANSFORMATION TO WAVENUMBER SPACE (FORWARD TRANSFORM) COMPLETE
C
         RETURN
C
      ELSE
C
C        INVERSE TRANSFORM FROM WAVENUMBER TO PHYSICAL SPACE (ITYPE=+1)
C        DETERMINE FOURIER COEFFICIENTS BY INVERSE LEGENDRE TRANSFORM.
C        VARY M AND N SO PROCEDURE MOVES ALONG DIAGONALS DENOTED BY
C        INDEX JN.  M IS GIVEN BY (JM-1) WHILE N IS GIVEN BY (JN+M).
C        FIRST ACCUMULATE EVEN WAVENUMBER CONTRIBUTION
C
         DO 180 JN=0,NN,2
            IS = LDIAG(JN,2)
C
C           THIS DETOUR HELPS AVOID THE NEED TO SEPARATELY ZERO CEVEN
C
            IF (JN.EQ.0) THEN
               DO 150 JM=1,MM+1
                  DO 140 NL=1,NLAT/2
                     CEVEN(NL,JM) = SCOEF(IS+JM)*ALP(IS+JM,NL)
  140             CONTINUE
  150          CONTINUE
C
            ELSE
C
               DO 170 JM=1,LDIAG(JN,1)
                  DO 160 NL=1,NLAT/2
                     CEVEN(NL,JM) = CEVEN(NL,JM) +
     $                             SCOEF(IS+JM)*ALP(IS+JM,NL)
  160             CONTINUE
  170          CONTINUE
            ENDIF
  180    CONTINUE
C
C        NEXT ACCUMULATE ODD WAVENUMBER CONTRIBUTION
C
         DO 215 JN=1,NN,2
            IS = LDIAG(JN,2)
C
C           THIS DETOUR HELPS AVOID THE NEED TO SEPARATELY ZERO CODD
C
            IF (JN.EQ.1) THEN
               DO 190 JM=1,LDIAG(1,1)
                  DO 185 NL=1,NLAT/2
                     CODD (NL,JM) = SCOEF(IS+JM)*ALP(IS+JM,NL)
  185             CONTINUE
  190          CONTINUE
C
C           ACCOUNT FOR THE FACT THAT THE FIRST ODD DIAGONAL MAY BE
C           SHORTER THAN THE FIRST EVEN DIAGONAL (PART OF THE GAME
C           TO AVOID EXPLICITLY ZEROING THE ENTIRE CODD ARRAY)
C
               IF (LDIAG(1,1) .LT. MM+1) THEN
                  DO 200 JM=LDIAG(1,1)+1, MM+1
                     DO 195 NL=1,NLAT/2
                        CODD (NL,JM) =  (0.0,0.0)
  195                CONTINUE
  200             CONTINUE
C
               ENDIF
            ELSE
C
               DO 210 JM=1,LDIAG(JN,1)
                  DO 205 NL=1,NLAT/2
                     CODD (NL,JM) = CODD (NL,JM) +
     $                             SCOEF(IS+JM)*ALP(IS+JM,NL)
  205             CONTINUE
  210          CONTINUE
C
            ENDIF
  215    CONTINUE
C
C        COMBINE CONTRIBUTIONS OF EVEN AND ODD WAVENUMBERS TO OBTAIN
C        COMPLEX FOURIER COEFFICIENTS, FOLLOWED BY INVERSE FFT
C
         DO 225 JM=1,MM+1
            DO 220 NL=1,NLAT/2
               SL = NLAT-NL+1
C              X(JM,NL,LV)        = CEVEN(NL,JM) + CODD(NL,JM)
               X(2*JM-1,NL,LV) = REAL(CEVEN(NL,JM)+CODD(NL,JM))
               X(2*JM,NL,LV)   = AIMAG(CEVEN(NL,JM)+CODD(NL,JM))
C              X(JM,NLAT-NL+1,LV) = CEVEN(NL,JM) - CODD(NL,JM)
               X(2*JM-1,SL,LV) = REAL(CEVEN(NL,JM)-CODD(NL,JM))
               X(2*JM,SL,LV)   = AIMAG(CEVEN(NL,JM)-CODD(NL,JM))
  220       CONTINUE
  225    CONTINUE
C
C        ZERO THE TAIL OF THE COMPLEX COEFFICIENT SPECTRUM
C
         DO 235 JM=MM+2,NFC
            DO 230 NL=1,NLAT
C              X(JM,NL,LV) = (0.0,0.0)
               X(2*JM-1,NL,LV) = 0.0
               X(2*JM,NL,LV)   = 0.0
  230       CONTINUE
  235    CONTINUE
C
C        INVERSE FAST FOURIER TRAANSFORM FOR ALL LATITUDES
C        AND TIMELEVEL LV
C
         CALL FFT991(X(1,1,LV),FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,
     $                  NLAT,+1)
C
C        TRANSFORMATION TO PHYSICAL SPACE (INVERSE TRANSFORM) COMPLETE
C
         RETURN
C
      ENDIF
C
      END


c------------------------------------------------------------------------------

      program main
            implicit none
            integer seed, Nx, Ny, i, j, k
		integer start, generate_spin, energy
            parameter(Nx=16)
            parameter(Ny=16)
            integer spins(Nx,Ny)
		integer ene, Ns
		real*8 beta

		open(unit=1, file='16x16.dat', status='unknown')

		write(*,*)'Enter Seed for Random Number Generator'
		read(*,*), seed
		call srand(seed)

            write(*,*)'Enter 1 for a Cold Start and 2 for a Hot Start'
            read(*,*) start

            do i = 1, Nx, +1
                  do j = 1, Ny, +1
                        spins(i,j) = generate_spin(start)
                  end do
            end do

c            call print_lattice(spins, Nx, Ny)

		ene = energy(spins, Nx, Ny)
		write(*,*)'Initial Energy = ',ene

		Ns = 1000
		beta = 0.1d0
		do k = 1, 90, +1
			beta = beta + 0.01d0
			call metropolis(spins, beta, Ns, Nx, Ny)
		end do

		close(unit=1)
      end

c------------------------------------------------------------------------------

      integer function generate_spin(start)
            implicit none
            integer start, s
            real*8 rval, rand

            if (start .eq. 1) then
                  s = 1
            else
                  rval = rand()
                  if (rval .lt. 0.5d0) then
                        s = -1
                  else
                        s = 1
                  end if
            end if

            generate_spin = s
            return
      end

c------------------------------------------------------------------------------

      subroutine print_lattice(spins, Nx, Ny)
            implicit none
            integer i, j, Nx, Ny
            integer spins(Nx,Ny)

            do i = 1, Nx, +1
                  do j = 1, Ny, +1
                        if (spins(i,j) .eq. 1) then
                              write(*,100) '+'
                        end if
                        if (spins(i,j) .eq. -1) then
                              write(*,100) '-'
                        end if
100                     format(a2, $)
                  end do
                  write(*,*)
            end do
      end

c------------------------------------------------------------------------------

	integer function energy(spins,Nx,Ny)
		implicit none
		integer i, j, Nx, Ny
		integer spins(Nx,Ny)
		integer left, right, up, down
		integer en, total_energy

		en = 0
		total_energy = 0
		left = 1
		right = 1
		up = 1
		down = 1

		do i = 1, Nx, +1
			do j = 1, Ny, +1

				left = i - 1
				right = i + 1
				up = j - 1
				down = j + 1

				if (i .eq. 1) then
					left = Nx
				end if

				if (i .eq. Nx) then
					right = 1
				end if

				if (j .eq. 1) then
					up = Ny
				end if

				if (j .eq. Ny) then
					down = 1
				end if

				en = -spins(i,j)*(spins(left,j)+
     > 			spins(i,up)+spins(right,j)+spins(i,down))
				total_energy = total_energy + en
			end do
		end do

		energy = total_energy
		return
	end

c------------------------------------------------------------------------------

	subroutine metropolis(spins, beta, Ns, Nx, Ny)
		implicit none
		real*8 M, beta, eta, rand, error
		integer i_t, j_t, energy, currentEnergy, newEnergy
		integer magnetisation
		integer deltaEnergy
            integer sweep, i, j, Nx, Ny, Ns
            integer spins(Nx,Ny)
		integer thermalise, N, mag, msquared

		thermalise = 100
		N = 0
		M = 0

		do sweep = 1, (Ns + thermalise), +1
			currentEnergy = energy(spins, Nx, Ny)

			i_t = idint(Nx*rand()) + 1
			j_t = idint(Ny*rand()) + 1
			spins(i_t, j_t) = -spins(i_t, j_t)

			newEnergy = energy(spins, Nx, Ny)
			deltaEnergy = newEnergy - currentEnergy
			eta = rand()

			if (deltaEnergy .ge. 0) then
				if (dexp(-beta*deltaEnergy) .le. eta) then
					spins(i_t, j_t) = -spins(i_t, j_t)
				end if
			end if

c			call print_lattice(spins, Nx, Ny)
c			pause

			if (sweep .gt. thermalise) then
				if (mod(sweep, 10) .eq. 0d0) then
					N = N + 1
					mag = magnetisation(spins, Nx, Ny)
					M = M + mag
					msquared = msquared + mag**2
				end if
			end if
		end do

		M = M/dfloat(N)
		msquared = msquared/dfloat(N)
		error = dsqrt((msquared - M**2)/dfloat(N))
		write(*,*)'beta, M, error = ', beta, dabs(M), error
		write(1,*) beta, dabs(M), error
	end
c------------------------------------------------------------------------------

	integer function magnetisation(spins, Nx, Ny)
		implicit none
		integer i, j, Nx, Ny
		integer spins(Nx,Ny)
		integer mag

		mag = 0

		do i = 1, Nx, +1
			do j = 1, Ny, +1
				mag = mag + spins(i,j)
			end do
		end do

		magnetisation = mag
		return
	end


      REAL FUNCTION SCASUM(N,CX,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 CLL Typing all variables.
C>> 1985-08-02 SCASUM Lawson  Initial code.
C     RETURNS SUMS OF MAGNITUDES OF REAL AND IMAGINARY PARTS OF
C     COMPONENTS OF CX.  NOTE THAT THIS IS NOT THE L1 NORM OF CX.
C     CASUM = SUM FROM 0 TO N-1 OF ABS(REAL(CX(1+I*INCX))) +
C             ABS(IMAG(CX(1+I*INCX)))
C
      integer I, INCX, N
      COMPLEX CX(*)
C
      SCASUM=0.0e0
      IF(N .LE. 0) RETURN
         DO 10 I=1,N*INCX,INCX
            SCASUM = SCASUM + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I)))
   10    CONTINUE
      RETURN
      END


!------------------------------------------------------------------------------
!
! MODULE:
!
! DESCRIPTION:
!>  Short module description
!
! REVISION HISTORY:
! 13 11 2021- Initial Version
! TODO_dd_mmm_yyyy - TODO_describe_appropriate_changes - TODO_name
!
! Range of x: L = loop * h
!------------------------------------------------------------------------------
module parameters
    implicit none
    integer, parameter :: n = 2               ! rank number
    integer, parameter :: loop = 10           ! max loop number
    double precision, parameter :: h = 1.d0   ! step size

    !---select Example number
    integer, parameter :: select = 3
    ! select = 1: Airy equation
    ! select = 2: Lecture
    ! select = 3: Report
    integer :: count  ! count number for select = 3

end module

!------------------------------------------------------------------------------
!
module func_param
    use parameters
    implicit none
    ! Define the function f(x, y)
    double precision :: x    ! Differential variable
    double precision :: y(n) ! Solution vector y = (y, dy/dx)
    double precision :: f(n) ! dy/dx = f (vector)

end module

module func_param2
    use parameters
    implicit none

    ! Define the function u, z (y = u + Cz)
    double precision :: u(n), z(n)

end module


      SUBROUTINE CDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH,
     $                   A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S,
     $                   SSAV, E, WORK, LWORK, RWORK, IWORK, NOUNIT,
     $                   INFO )
*
*  -- LAPACK test routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     April 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDU, LDVT, LWORK, NOUNIT, NSIZES,
     $                   NTYPES
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
      REAL               E( * ), RWORK( * ), S( * ), SSAV( * )
      COMPLEX            A( LDA, * ), ASAV( LDA, * ), U( LDU, * ),
     $                   USAV( LDU, * ), VT( LDVT, * ),
     $                   VTSAV( LDVT, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  CDRVBD checks the singular value decomposition (SVD) driver CGESVD
*  and CGESDD.
*  CGESVD and CGESDD factors A = U diag(S) VT, where U and VT are
*  unitary and diag(S) is diagonal with the entries of the array S on
*  its diagonal. The entries of S are the singular values, nonnegative
*  and stored in decreasing order.  U and VT can be optionally not
*  computed, overwritten on A, or computed partially.
*
*  A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
*  U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
*
*  When CDRVBD is called, a number of matrix "sizes" (M's and N's)
*  and a number of matrix "types" are specified.  For each size (M,N)
*  and each type of matrix, and for the minimal workspace as well as
*  workspace adequate to permit blocking, an  M x N  matrix "A" will be
*  generated and used to test the SVD routines.  For each matrix, A will
*  be factored as A = U diag(S) VT and the following 12 tests computed:
*
*  Test for CGESVD:
*
*  (1)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
*  (2)   | I - U'U | / ( M ulp )
*
*  (3)   | I - VT VT' | / ( N ulp )
*
*  (4)   S contains MNMIN nonnegative values in decreasing order.
*        (Return 0 if true, 1/ULP if false.)
*
*  (5)   | U - Upartial | / ( M ulp ) where Upartial is a partially
*        computed U.
*
*  (6)   | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
*        computed VT.
*
*  (7)   | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
*        vector of singular values from the partial SVD
*
*  Test for CGESDD:
*
*  (1)   | A - U diag(S) VT | / ( |A| max(M,N) ulp )
*
*  (2)   | I - U'U | / ( M ulp )
*
*  (3)   | I - VT VT' | / ( N ulp )
*
*  (4)   S contains MNMIN nonnegative values in decreasing order.
*        (Return 0 if true, 1/ULP if false.)
*
*  (5)   | U - Upartial | / ( M ulp ) where Upartial is a partially
*        computed U.
*
*  (6)   | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
*        computed VT.
*
*  (7)   | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
*        vector of singular values from the partial SVD
*
*  The "sizes" are specified by the arrays MM(1:NSIZES) and
*  NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
*  specifies one size.  The "types" are specified by a logical array
*  DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j"
*  will be generated.
*  Currently, the list of possible types is:
*
*  (1)  The zero matrix.
*  (2)  The identity matrix.
*  (3)  A matrix of the form  U D V, where U and V are unitary and
*       D has evenly spaced entries 1, ..., ULP with random signs
*       on the diagonal.
*  (4)  Same as (3), but multiplied by the underflow-threshold / ULP.
*  (5)  Same as (3), but multiplied by the overflow-threshold * ULP.
*
*  Arguments
*  ==========
*
*  NSIZES  (input) INTEGER
*          The number of sizes of matrices to use.  If it is zero,
*          CDRVBD does nothing.  It must be at least zero.
*
*  MM      (input) INTEGER array, dimension (NSIZES)
*          An array containing the matrix "heights" to be used.  For
*          each j=1,...,NSIZES, if MM(j) is zero, then MM(j) and NN(j)
*          will be ignored.  The MM(j) values must be at least zero.
*
*  NN      (input) INTEGER array, dimension (NSIZES)
*          An array containing the matrix "widths" to be used.  For
*          each j=1,...,NSIZES, if NN(j) is zero, then MM(j) and NN(j)
*          will be ignored.  The NN(j) values must be at least zero.
*
*  NTYPES  (input) INTEGER
*          The number of elements in DOTYPE.   If it is zero, CDRVBD
*          does nothing.  It must be at least zero.  If it is MAXTYP+1
*          and NSIZES is 1, then an additional type, MAXTYP+1 is
*          defined, which is to use whatever matrices are in A and B.
*          This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
*          DOTYPE(MAXTYP+1) is .TRUE. .
*
*  DOTYPE  (input) LOGICAL array, dimension (NTYPES)
*          If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
*          of type j will be generated.  If NTYPES is smaller than the
*          maximum number of types defined (PARAMETER MAXTYP), then
*          types NTYPES+1 through MAXTYP will not be generated.  If
*          NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
*          DOTYPE(NTYPES) will be ignored.
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry ISEED specifies the seed of the random number
*          generator. The array elements should be between 0 and 4095;
*          if not they will be reduced mod 4096.  Also, ISEED(4) must
*          be odd.  The random number generator uses a linear
*          congruential sequence limited to small integers, and so
*          should produce machine independent random numbers. The
*          values of ISEED are changed on exit, and can be used in the
*          next call to CDRVBD to continue the same random number
*          sequence.
*
*  THRESH  (input) REAL
*          A test will count as "failed" if the "error", computed as
*          described above, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  NOUNIT  (input) INTEGER
*          The FORTRAN unit number for printing out error messages
*          (e.g., if a routine returns IINFO not equal to 0.)
*
*  A       (output) COMPLEX array, dimension (LDA,max(NN))
*          Used to hold the matrix whose singular values are to be
*          computed.  On exit, A contains the last matrix actually
*          used.
*
*  LDA     (input) INTEGER
*          The leading dimension of A.  It must be at
*          least 1 and at least max( MM ).
*
*  U       (output) COMPLEX array, dimension (LDU,max(MM))
*          Used to hold the computed matrix of right singular vectors.
*          On exit, U contains the last such vectors actually computed.
*
*  LDU     (input) INTEGER
*          The leading dimension of U.  It must be at
*          least 1 and at least max( MM ).
*
*  VT      (output) COMPLEX array, dimension (LDVT,max(NN))
*          Used to hold the computed matrix of left singular vectors.
*          On exit, VT contains the last such vectors actually computed.
*
*  LDVT    (input) INTEGER
*          The leading dimension of VT.  It must be at
*          least 1 and at least max( NN ).
*
*  ASAV    (output) COMPLEX array, dimension (LDA,max(NN))
*          Used to hold a different copy of the matrix whose singular
*          values are to be computed.  On exit, A contains the last
*          matrix actually used.
*
*  USAV    (output) COMPLEX array, dimension (LDU,max(MM))
*          Used to hold a different copy of the computed matrix of
*          right singular vectors. On exit, USAV contains the last such
*          vectors actually computed.
*
*  VTSAV   (output) COMPLEX array, dimension (LDVT,max(NN))
*          Used to hold a different copy of the computed matrix of
*          left singular vectors. On exit, VTSAV contains the last such
*          vectors actually computed.
*
*  S       (output) REAL array, dimension (max(min(MM,NN)))
*          Contains the computed singular values.
*
*  SSAV    (output) REAL array, dimension (max(min(MM,NN)))
*          Contains another copy of the computed singular values.
*
*  E       (output) REAL array, dimension (max(min(MM,NN)))
*          Workspace for CGESVD.
*
*  WORK    (workspace) COMPLEX array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The number of entries in WORK.  This must be at least
*          MAX(3*MIN(M,N)+MAX(M,N)**2,5*MIN(M,N),3*MAX(M,N)) for all
*          pairs  (M,N)=(MM(j),NN(j))
*
*  RWORK   (workspace) REAL array,
*                      dimension ( 5*max(max(MM,NN)) )
*
*  IWORK   (workspace) INTEGER array, dimension at least 8*min(M,N)
*
*  RESULT  (output) REAL array, dimension (7)
*          The values computed by the 7 tests described above.
*          The values are currently limited to 1/ULP, to avoid
*          overflow.
*
*  INFO    (output) INTEGER
*          If 0, then everything ran OK.
*           -1: NSIZES < 0
*           -2: Some MM(j) < 0
*           -3: Some NN(j) < 0
*           -4: NTYPES < 0
*           -7: THRESH < 0
*          -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
*          -12: LDU < 1 or LDU < MMAX.
*          -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
*          -21: LWORK too small.
*          If  CLATMS, or CGESVD returns an error code, the
*              absolute value of it is returned.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
      INTEGER            MAXTYP
      PARAMETER          ( MAXTYP = 5 )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADMM, BADNN
      CHARACTER          JOBQ, JOBU, JOBVT
      INTEGER            I, IINFO, IJQ, IJU, IJVT, IWSPC, IWTMP, J,
     $                   JSIZE, JTYPE, LSWORK, M, MINWRK, MMAX, MNMAX,
     $                   MNMIN, MTYPES, N, NERRS, NFAIL, NMAX, NTEST,
     $                   NTESTF, NTESTT
      REAL               ANORM, DIF, DIV, OVFL, ULP, ULPINV, UNFL
*     ..
*     .. Local Arrays ..
      CHARACTER          CJOB( 4 )
      INTEGER            IOLDSD( 4 )
      REAL               RESULT( 14 )
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALASVM, CBDT01, LA_TEST_CGESDD, LA_TEST_CGESVD,
     &                   CLACPY, CLASET, CLATMS, CUNT01, CUNT03, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL
*     ..
*     .. Data statements ..
      DATA               CJOB / 'N', 'O', 'S', 'A' /
*     ..
*     .. Executable Statements ..
*
*     Check for errors
*
      INFO = 0
*
*     Important constants
*
      NERRS = 0
      NTESTT = 0
      NTESTF = 0
      BADMM = .FALSE.
      BADNN = .FALSE.
      MMAX = 1
      NMAX = 1
      MNMAX = 1
      MINWRK = 1
      DO 10 J = 1, NSIZES
         MMAX = MAX( MMAX, MM( J ) )
         IF( MM( J ).LT.0 )
     $      BADMM = .TRUE.
         NMAX = MAX( NMAX, NN( J ) )
         IF( NN( J ).LT.0 )
     $      BADNN = .TRUE.
         MNMAX = MAX( MNMAX, MIN( MM( J ), NN( J ) ) )
         MINWRK = MAX( MINWRK, MAX( 3*MIN( MM( J ),
     $            NN( J ) )+MAX( MM( J ), NN( J ) )**2, 5*MIN( MM( J ),
     $            NN( J ) ), 3*MAX( MM( J ), NN( J ) ) ) )
   10 CONTINUE
*
*     Check for errors
*
      IF( NSIZES.LT.0 ) THEN
         INFO = -1
      ELSE IF( BADMM ) THEN
         INFO = -2
      ELSE IF( BADNN ) THEN
         INFO = -3
      ELSE IF( NTYPES.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, MMAX ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.MAX( 1, MMAX ) ) THEN
         INFO = -12
      ELSE IF( LDVT.LT.MAX( 1, NMAX ) ) THEN
         INFO = -14
      ELSE IF( MINWRK.GT.LWORK ) THEN
         INFO = -21
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CDRVBD', -INFO )
         RETURN
      END IF
*
*     Quick return if nothing to do
*
      IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
     $   RETURN
*
*     More Important constants
*
      UNFL = SLAMCH( 'S' )
      OVFL = ONE / UNFL
      ULP = SLAMCH( 'E' )
      ULPINV = ONE / ULP
*
*     Loop over sizes, types
*
      NERRS = 0
*
      DO 180 JSIZE = 1, NSIZES
         M = MM( JSIZE )
         N = NN( JSIZE )
         MNMIN = MIN( M, N )
*
         IF( NSIZES.NE.1 ) THEN
            MTYPES = MIN( MAXTYP, NTYPES )
         ELSE
            MTYPES = MIN( MAXTYP+1, NTYPES )
         END IF
*
         DO 170 JTYPE = 1, MTYPES
            IF( .NOT.DOTYPE( JTYPE ) )
     $         GO TO 170
            NTEST = 0
*
            DO 20 J = 1, 4
               IOLDSD( J ) = ISEED( J )
   20       CONTINUE
*
*           Compute "A"
*
            IF( MTYPES.GT.MAXTYP )
     $         GO TO 50
*
            IF( JTYPE.EQ.1 ) THEN
*
*              Zero matrix
*
               CALL CLASET( 'Full', M, N, CZERO, CZERO, A, LDA )
               DO 30 I = 1, MIN( M, N )
                  S( I ) = ZERO
   30          CONTINUE
*
            ELSE IF( JTYPE.EQ.2 ) THEN
*
*              Identity matrix
*
               CALL CLASET( 'Full', M, N, CZERO, CONE, A, LDA )
               DO 40 I = 1, MIN( M, N )
                  S( I ) = ONE
   40          CONTINUE
*
            ELSE
*
*              (Scaled) random matrix
*
               IF( JTYPE.EQ.3 )
     $            ANORM = ONE
               IF( JTYPE.EQ.4 )
     $            ANORM = UNFL / ULP
               IF( JTYPE.EQ.5 )
     $            ANORM = OVFL*ULP
               CALL CLATMS( M, N, 'U', ISEED, 'N', S, 4, REAL( MNMIN ),
     $                      ANORM, M-1, N-1, 'N', A, LDA, WORK, IINFO )
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUNIT, FMT = 9996 )'Generator', IINFO, M, N,
     $               JTYPE, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
            END IF
*
   50       CONTINUE
            CALL CLACPY( 'F', M, N, A, LDA, ASAV, LDA )
*
*           Do for minimal and adequate (for blocking) workspace
*
            DO 160 IWSPC = 1, 4
*
*              Test for CGESVD
*
               IWTMP = MAX( 3*MIN( M, N )+MAX( M, N ), 5*MIN( M, N )-4 )
               LSWORK = IWTMP + ( IWSPC-1 )*( LWORK-IWTMP ) / 3
               LSWORK = MIN( LSWORK, LWORK )
               LSWORK = MAX( LSWORK, 1 )
               IF( IWSPC.EQ.4 )
     $            LSWORK = LWORK
*
               DO 60 J = 1, 14
                  RESULT( J ) = -ONE
   60          CONTINUE
*
*              Factorize A
*
               IF( IWSPC.GT.1 )
     $            CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA )
	       IINFO = 0
               CALL LA_TEST_CGESVD( 'A', 'A', M, N, A, LDA, SSAV, USAV,
     &           LDU, VTSAV, LDVT, WORK, LSWORK, RWORK, IINFO )
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUNIT, FMT = 9995 )'GESVD', IINFO, M, N,
     $               JTYPE, LSWORK, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
*              Do tests 1--4
*
               CALL CBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
     $                      VTSAV, LDVT, WORK, RWORK, RESULT( 1 ) )
               IF( M.NE.0 .AND. N.NE.0 ) THEN
                  CALL CUNT01( 'Columns', MNMIN, M, USAV, LDU, WORK,
     $                         LWORK, RWORK, RESULT( 2 ) )
                  CALL CUNT01( 'Rows', MNMIN, N, VTSAV, LDVT, WORK,
     $                         LWORK, RWORK, RESULT( 3 ) )
               END IF
               RESULT( 4 ) = 0
               DO 70 I = 1, MNMIN - 1
                  IF( SSAV( I ).LT.SSAV( I+1 ) )
     $               RESULT( 4 ) = ULPINV
                  IF( SSAV( I ).LT.ZERO )
     $               RESULT( 4 ) = ULPINV
   70          CONTINUE
               IF( MNMIN.GE.1 ) THEN
                  IF( SSAV( MNMIN ).LT.ZERO )
     $               RESULT( 4 ) = ULPINV
               END IF
*
*              Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
               RESULT( 5 ) = ZERO
               RESULT( 6 ) = ZERO
               RESULT( 7 ) = ZERO
               DO 100 IJU = 0, 3
                  DO 90 IJVT = 0, 3
                     IF( ( IJU.EQ.3 .AND. IJVT.EQ.3 ) .OR.
     $                   ( IJU.EQ.1 .AND. IJVT.EQ.1 ) )GO TO 90
                     JOBU = CJOB( IJU+1 )
                     JOBVT = CJOB( IJVT+1 )
                     CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA )
                     IINFO = 0
                     CALL LA_TEST_CGESVD( JOBU, JOBVT, M, N, A, LDA, S,
     &                 U, LDU, VT, LDVT, WORK, LSWORK, RWORK, IINFO )
*
*                    Compare U
*
                     DIF = ZERO
                     IF( M.GT.0 .AND. N.GT.0 ) THEN
                        IF( IJU.EQ.1 ) THEN
                           CALL CUNT03( 'C', M, MNMIN, M, MNMIN, USAV,
     $                                  LDU, A, LDA, WORK, LWORK, RWORK,
     $                                  DIF, IINFO )
                        ELSE IF( IJU.EQ.2 ) THEN
                           CALL CUNT03( 'C', M, MNMIN, M, MNMIN, USAV,
     $                                  LDU, U, LDU, WORK, LWORK, RWORK,
     $                                  DIF, IINFO )
                        ELSE IF( IJU.EQ.3 ) THEN
                           CALL CUNT03( 'C', M, M, M, MNMIN, USAV, LDU,
     $                                  U, LDU, WORK, LWORK, RWORK, DIF,
     $                                  IINFO )
                        END IF
                     END IF
                     RESULT( 5 ) = MAX( RESULT( 5 ), DIF )
*
*                    Compare VT
*
                     DIF = ZERO
                     IF( M.GT.0 .AND. N.GT.0 ) THEN
                        IF( IJVT.EQ.1 ) THEN
                           CALL CUNT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
     $                                  LDVT, A, LDA, WORK, LWORK,
     $                                  RWORK, DIF, IINFO )
                        ELSE IF( IJVT.EQ.2 ) THEN
                           CALL CUNT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
     $                                  LDVT, VT, LDVT, WORK, LWORK,
     $                                  RWORK, DIF, IINFO )
                        ELSE IF( IJVT.EQ.3 ) THEN
                           CALL CUNT03( 'R', N, N, N, MNMIN, VTSAV,
     $                                  LDVT, VT, LDVT, WORK, LWORK,
     $                                  RWORK, DIF, IINFO )
                        END IF
                     END IF
                     RESULT( 6 ) = MAX( RESULT( 6 ), DIF )
*
*                    Compare S
*
                     DIF = ZERO
                     DIV = MAX( REAL( MNMIN )*ULP*S( 1 ),
     $                     SLAMCH( 'Safe minimum' ) )
                     DO 80 I = 1, MNMIN - 1
                        IF( SSAV( I ).LT.SSAV( I+1 ) )
     $                     DIF = ULPINV
                        IF( SSAV( I ).LT.ZERO )
     $                     DIF = ULPINV
                        DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
   80                CONTINUE
                     RESULT( 7 ) = MAX( RESULT( 7 ), DIF )
   90             CONTINUE
  100          CONTINUE
*
*              Test for CGESDD
*
               IWTMP = 2*MNMIN*MNMIN + 2*MNMIN + MAX( M, N )
               LSWORK = IWTMP + ( IWSPC-1 )*( LWORK-IWTMP ) / 3
               LSWORK = MIN( LSWORK, LWORK )
               LSWORK = MAX( LSWORK, 1 )
               IF( IWSPC.EQ.4 )
     $            LSWORK = LWORK
*
*              Factorize A
*
      CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA )
      IINFO = 0
               CALL LA_TEST_CGESDD( 'A', M, N, A, LDA, SSAV, USAV,
     &                      LDU, VTSAV,
     $                      LDVT, WORK, LSWORK, RWORK, IWORK, IINFO )
               IF( IINFO.NE.0 ) THEN
                  WRITE( NOUNIT, FMT = 9995 )'GESDD', IINFO, M, N,
     $               JTYPE, LSWORK, IOLDSD
                  INFO = ABS( IINFO )
                  RETURN
               END IF
*
*              Do tests 1--4
*
               CALL CBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
     $                      VTSAV, LDVT, WORK, RWORK, RESULT( 8 ) )
               IF( M.NE.0 .AND. N.NE.0 ) THEN
                  CALL CUNT01( 'Columns', MNMIN, M, USAV, LDU, WORK,
     $                         LWORK, RWORK, RESULT( 9 ) )
                  CALL CUNT01( 'Rows', MNMIN, N, VTSAV, LDVT, WORK,
     $                         LWORK, RWORK, RESULT( 10 ) )
               END IF
               RESULT( 11 ) = 0
               DO 110 I = 1, MNMIN - 1
                  IF( SSAV( I ).LT.SSAV( I+1 ) )
     $               RESULT( 11 ) = ULPINV
                  IF( SSAV( I ).LT.ZERO )
     $               RESULT( 11 ) = ULPINV
  110          CONTINUE
               IF( MNMIN.GE.1 ) THEN
                  IF( SSAV( MNMIN ).LT.ZERO )
     $               RESULT( 11 ) = ULPINV
               END IF
*
*              Do partial SVDs, comparing to SSAV, USAV, and VTSAV
*
               RESULT( 12 ) = ZERO
               RESULT( 13 ) = ZERO
               RESULT( 14 ) = ZERO
               DO 130 IJQ = 0, 2
                  JOBQ = CJOB( IJQ+1 )
                  CALL CLACPY( 'F', M, N, ASAV, LDA, A, LDA )
                  IINFO = 0
                  CALL LA_TEST_CGESDD( JOBQ, M, N, A, LDA, S, U, LDU,
     &                         VT, LDVT,
     $                         WORK, LSWORK, RWORK, IWORK, IINFO )
*
*                 Compare U
*
                  DIF = ZERO
                  IF( M.GT.0 .AND. N.GT.0 ) THEN
                     IF( IJQ.EQ.1 ) THEN
                        IF( M.GE.N ) THEN
                           CALL CUNT03( 'C', M, MNMIN, M, MNMIN, USAV,
     $                                  LDU, A, LDA, WORK, LWORK, RWORK,
     $                                  DIF, IINFO )
                        ELSE
                           CALL CUNT03( 'C', M, MNMIN, M, MNMIN, USAV,
     $                                  LDU, U, LDU, WORK, LWORK, RWORK,
     $                                  DIF, IINFO )
                        END IF
                     ELSE IF( IJQ.EQ.2 ) THEN
                        CALL CUNT03( 'C', M, MNMIN, M, MNMIN, USAV, LDU,
     $                               U, LDU, WORK, LWORK, RWORK, DIF,
     $                               IINFO )
                     END IF
                  END IF
                  RESULT( 12 ) = MAX( RESULT( 12 ), DIF )
*
*                 Compare VT
*
                  DIF = ZERO
                  IF( M.GT.0 .AND. N.GT.0 ) THEN
                     IF( IJQ.EQ.1 ) THEN
                        IF( M.GE.N ) THEN
                           CALL CUNT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
     $                                  LDVT, VT, LDVT, WORK, LWORK,
     $                                  RWORK, DIF, IINFO )
                        ELSE
                           CALL CUNT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
     $                                  LDVT, A, LDA, WORK, LWORK,
     $                                  RWORK, DIF, IINFO )
                        END IF
                     ELSE IF( IJQ.EQ.2 ) THEN
                        CALL CUNT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
     $                               LDVT, VT, LDVT, WORK, LWORK, RWORK,
     $                               DIF, IINFO )
                     END IF
                  END IF
                  RESULT( 13 ) = MAX( RESULT( 13 ), DIF )
*
*                 Compare S
*
                  DIF = ZERO
                  DIV = MAX( REAL( MNMIN )*ULP*S( 1 ),
     $                  SLAMCH( 'Safe minimum' ) )
                  DO 120 I = 1, MNMIN - 1
                     IF( SSAV( I ).LT.SSAV( I+1 ) )
     $                  DIF = ULPINV
                     IF( SSAV( I ).LT.ZERO )
     $                  DIF = ULPINV
                     DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
  120             CONTINUE
                  RESULT( 14 ) = MAX( RESULT( 14 ), DIF )
  130          CONTINUE
*
*              End of Loop -- Check for RESULT(j) > THRESH
*
               NTEST = 0
               NFAIL = 0
               DO 140 J = 1, 14
                  IF( RESULT( J ).GE.ZERO )
     $               NTEST = NTEST + 1
                  IF( RESULT( J ).GE.THRESH )
     $               NFAIL = NFAIL + 1
  140          CONTINUE
*
               IF( NFAIL.GT.0 )
     $            NTESTF = NTESTF + 1
               IF( NTESTF.EQ.1 ) THEN
                  WRITE( NOUNIT, FMT = 9999 )
                  WRITE( NOUNIT, FMT = 9998 )THRESH
                  NTESTF = 2
               END IF
*
               DO 150 J = 1, 14
                  IF( RESULT( J ).GE.THRESH ) THEN
                     WRITE( NOUNIT, FMT = 9997 )M, N, JTYPE, IWSPC,
     $                  IOLDSD, J, RESULT( J )
                  END IF
  150          CONTINUE
*
               NERRS = NERRS + NFAIL
               NTESTT = NTESTT + NTEST
*
  160       CONTINUE
*
  170    CONTINUE
  180 CONTINUE
*
*     Summary
*
      CALL ALASVM( 'CBD', NOUNIT, NERRS, NTESTT, 0 )
*
 9999 FORMAT( ' SVD -- Complex Singular Value Decomposition Driver ',
     $      / ' Matrix types (see CDRVBD for details):',
     $      / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
     $      / ' 3 = Evenly spaced singular values near 1',
     $      / ' 4 = Evenly spaced singular values near underflow',
     $      / ' 5 = Evenly spaced singular values near overflow',
     $      / / ' Tests performed: ( A is dense, U and V are unitary,',
     $      / 19X, ' S is an array, and Upartial, VTpartial, and',
     $      / 19X, ' Spartial are partially computed U, VT and S),', / )
 9998 FORMAT( ' Tests performed with Test Threshold = ', F8.2,
     $      / ' CGESVD: ', /
     $      ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
     $      / ' 2 = | I - U**T U | / ( M ulp ) ',
     $      / ' 3 = | I - VT VT**T | / ( N ulp ) ',
     $      / ' 4 = 0 if S contains min(M,N) nonnegative values in',
     $      ' decreasing order, else 1/ulp',
     $      / ' 5 = | U - Upartial | / ( M ulp )',
     $      / ' 6 = | VT - VTpartial | / ( N ulp )',
     $      / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
     $      / ' CGESDD: ', /
     $      ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
     $      / ' 9 = | I - U**T U | / ( M ulp ) ',
     $      / '10 = | I - VT VT**T | / ( N ulp ) ',
     $      / '11 = 0 if S contains min(M,N) nonnegative values in',
     $      ' decreasing order, else 1/ulp',
     $      / '12 = | U - Upartial | / ( M ulp )',
     $      / '13 = | VT - VTpartial | / ( N ulp )',
     $      / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', / / )
 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1,
     $      ', seed=', 4( I4, ',' ), ' test(', I1, ')=', G11.4 )
 9996 FORMAT( ' CDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
     $      I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
     $      I5, ')' )
 9995 FORMAT( ' CDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
     $      I6, ', N=', I6, ', JTYPE=', I6, ', LSWORK=', I6, / 9X,
     $      'ISEED=(', 3( I5, ',' ), I5, ')' )
*
      RETURN
*
*     End of CDRVBD
*
      END


program test_libc
    use libc
    use, intrinsic :: iso_fortran_env
    implicit none

    call clock_example
    call mktime_example(2022,01,22) ! Saturday
    call difftime_example
    call localtime_example
    call time_example
    call strptime_example
    call strftime_example
    call asctime_example
    call gmtime_example
    call memory_example
    call strerror_example
    call srand_example
    call rand_example([5,7,4,1,2,3])
    call qsort_example

contains

    function frequency_of_primes(n) result(freq)
        integer, intent(in) :: n
        integer :: i,j,freq
        real(REAL64) :: is
        freq = n - 1
        do i = 2, n
            is = sqrt(real(i,REAL64))
            do j = int(is), 2, -1
                if (mod(i,j) == 0) then
                    freq = freq - 1
                    exit
                end if
            end do
        end do
    end function

    subroutine clock_example
        integer(c_clock_t) :: clock_start, clock_end, clocks_per_sec
        real(REAL64) :: time_start, time_end
        integer :: freq

        print '("> clock example")'

        clock_start = clock()
        call cpu_time(time_start)

        write(*,*) "Calculating..."
        freq = frequency_of_primes(99999)
        write(*,*) "The number of primes lower than 100,000 is: ", freq

        clock_end = clock()
        call cpu_time(time_end)
        clocks_per_sec = get_clocks_per_sec()
        print *, "clocks_per_sec = ", clocks_per_sec
        write(*,'("It took me ", i0," clicks (",f0.5," seconds)")') &
            clock_end-clock_start, &
            real(clock_end - clock_start,REAL64)/real(clocks_per_sec,REAL64)
        write(*,'("Fortran version: ",f0.5," seconds")') time_end - time_start
    end subroutine

    subroutine mktime_example(year, month, day)
        integer(c_int), optional :: year, month, day
        integer(c_time_t) :: rawtime, thattime
        type(c_tm_t)      :: timeinfo
        integer(c_int)    :: Y, M, D
        character(len=9) :: &
            weekday(0:6) = [character(len=9) :: &
                "Sunday",    "Monday",   "Tuesday", &
                "Wednesday", "Thursday", "Friday", "Saturday"]

        write(output_unit,'(A)') "> mktime example"
        if (.not. present(year)) then
            write(output_unit,"(A)",advance='no') "Enter year: "
            read(input_unit,*) Y
        else
            Y = year
        end if
        if (.not. present(month)) then
            write(output_unit,"(A)",advance='no') "Enter month: "
            read(input_unit,*) M
        else
            M = month
        end if
        if (M > 12 .or. M < 1) error stop "Invalid month"

        if (.not. present(day)) then
            write(output_unit,"(A)",advance='no') "Enter day: "
            read(input_unit,*) D
        else
            D = day
        end if
        if (M > 31 .or. M < 1) error stop "Invalid day"

        rawtime = time()
        timeinfo = localtime(rawtime)
        timeinfo % tm_year = Y - 1900
        timeinfo % tm_mon  = M - 1
        timeinfo % tm_mday = D

        thattime = mktime(timeinfo)
        timeinfo = localtime(thattime)

        write(output_unit,'("The input date is a ",A)') weekday(timeinfo%tm_wday)
    end subroutine

    subroutine difftime_example
        integer(c_time_t) :: now
        type(c_tm_t)   :: newyear
        real(c_double) :: seconds

        print '("> difftime example")'

        now = time()
        newyear = localtime(now)
        ! sec, min, hour, mday, mon, year, wday, yday, isdst
        print*, newyear

        newyear % tm_hour = 0 ! hour
        newyear % tm_min  = 0
        newyear % tm_sec  = 0
        newyear % tm_mon  = 0
        newyear % tm_mday = 1
        print *, newyear

        seconds = difftime(now, mktime(newyear))
        print '(i0," seconds since ",A," in the current timezone")',&
            int(seconds), "New Year"
        print '(i0," days since ",A," in the current timezone")',   &
            int(seconds/(24.*3600.)), "New Year"
    end subroutine

    subroutine localtime_example
        integer(c_time_t) :: rawtime
        type(c_tm_t) :: timeinfo

        print '("> localtime example")'

        rawtime = time()
        timeinfo = localtime(rawtime)

        write(*,*) "Current local time and date: ", asctime(timeinfo)
    end subroutine

    subroutine time_example
        integer(c_time_t) :: timer, that_time
        type(c_tm_t) :: y2k
        real(c_double) :: seconds

        print '("> time example")'

        y2k = c_tm_t()
        y2k % tm_mday = 1
        y2k % tm_year = 100
        y2k % tm_mon  = 0

        print *, y2k

        timer = time(timer)

        that_time = mktime(y2k)
        seconds = difftime(timer,that_time)
        print '(i0," seconds since ",A," in the current timezone")',&
            int(seconds), "January 1, 2000"
        print '(i0," days since ",A," in the current timezone")',   &
            int(seconds/(24.*3600.)), "January 1, 2000"

    end subroutine

    subroutine strptime_example
        integer(c_time_t) :: rawtime
        type(c_tm_t)      :: timeinfo
        character(:), allocatable :: ret
        real(c_double) :: seconds

        print '("> strptime example")'

        rawtime = time(rawtime)

        timeinfo = c_tm_t()

        ret = strptime("1992-08-21", "%F", timeinfo)
        if (ret /= c_null_char) then
            seconds = difftime(rawtime, mktime(timeinfo))
            write(*,*) seconds, " seconds since I was born"
            write(*,*) seconds/(24.*3600.), " days since I was born"
            write(*,*) seconds/(365.24*24.*3600.), " years since I was born"
        else
            error stop
        end if
    end subroutine

    subroutine strftime_example
        integer(c_time_t) :: rawtime
        type(c_tm_t) :: timeinfo

        character(len=80) :: buffer
        integer(c_size_t) :: ret

        print '("> strftime_example")'

        rawtime = time(rawtime)
        timeinfo = localtime(rawtime)
        ret = f_strftime(buffer, 80, "Now it's %I:%M %p.", timeinfo)
        write(*,*) buffer(1:ret)
    end subroutine

    subroutine asctime_example
        integer(c_time_t) :: rawtime
        type(c_tm_t)      :: timeinfo

        print '("> asctime example")'

        rawtime = time(rawtime)
        timeinfo = localtime(rawtime)

        print '("The current date/time is: ",A)', asctime(timeinfo)
    end subroutine

    subroutine gmtime_example
        integer(c_time_t) :: rawtime
        type(c_tm_t) :: tm
        integer(c_int), parameter :: MST = -7, UTC = 0, CCT = 8
        integer(c_int) :: hour, minutes

        print '("> gmtime example")'

        rawtime = time()
        tm = gmtime(rawtime)
        hour    = tm % tm_hour
        minutes = tm % tm_min

        print '("Current time around the world:")'
        print '("  Phoenix, AZ (U.S.):  ",i0.2,":",i0.2)', abs(mod(hour+MST,24)), minutes
        print '("  Reykjavik (Iceland): ",i0.2,":",i0.2)', abs(mod(hour+UTC,24)), minutes
        print '("  Beijing (China):     ",i0.2,":",i0.2)', abs(mod(hour+CCT,24)), minutes
    end subroutine

    subroutine memory_example
        integer, parameter :: MAX_SIZE = 5
        real(c_double)          :: a
        real(c_double), pointer :: b(:) => null()
        type(c_ptr)             :: b_ptr

        print '("> memory example")'

        b_ptr = c_malloc(c_sizeof(a)*MAX_SIZE)
        call c_f_pointer(b_ptr, b, [MAX_SIZE])
        if (.not. size(b) == MAX_SIZE) error stop "Assertion failed"

        b = 1.0
        b_ptr = c_realloc(b_ptr, c_sizeof(a)*(2*MAX_SIZE))
        call c_f_pointer(b_ptr, b, [2*MAX_SIZE])

        if (.not. size(b) == 2*MAX_SIZE) error stop "Assertion failed"

        b(MAX_SIZE+1:) = 2

        if (.not. all(abs(b(1:MAX_SIZE) - 1)  < epsilon(a))) error stop "Assertion failed"
        if (.not. all(abs(b(MAX_SIZE+1:) - 2) < epsilon(a))) error stop "Assertion failed"

        if (.not. c_associated(b_ptr)) error stop "Assertion failed"
        if (.not.   associated(b))     error stop "Assertion failed"

        call c_free(b_ptr)
        b_ptr = c_null_ptr
        nullify(b)

        if (c_associated(b_ptr)) error stop "Assertion failed"
        if (  associated(b))     error stop "Assertion failed"

        call c_f_pointer(b_ptr, b, [MAX_SIZE])

        if (c_associated(b_ptr)) error stop "Assertion failed"
        if (  associated(b))     error stop "Assertion failed"
    end subroutine

    subroutine strerror_example
        integer(c_int) :: i

        print '("> strerror example")'

        i = test_strerror()
        print '("The following error occurred: ",A)', strerror(get_errno())
        call perror("The following error occurred")
    end subroutine

    subroutine srand_example
        integer(c_int) :: count
        print '("> srand example")'

        call c_srand(1)
        print '("First number: ",i0)', mod(c_rand(),100)
        call system_clock(count)
        call c_srand(count)
        print '("Random number: ",i0)', mod(c_rand(),100)
        call c_srand(1)
        print '("Again the first number: ",i0)', mod(c_rand(),100)
    end subroutine

    subroutine rand_example(guesses)
        integer, intent(in), optional :: guesses(:)
        integer(c_int) :: secret, guess
        integer(c_int) :: count
        integer :: i

        print '("> rand example")'

        call system_clock(count)
        call c_srand(count)

        secret = mod(c_rand(),10) + 1

        i = 0
        do
            if (.not. present(guesses)) then
                write(*,'(A)',advance='no') "Guess the number (1 to 10): "
                read(*,*) guess
            else
                i = i + 1
                guess = guesses(i)
            end if
            if (secret < guess) then
                write(*,*) "The secret number is lower"
            else if (secret > guess) then
                write(*,*) "The secret number is higher"
            end if

            if (secret == guess) exit
            if (present(guesses)) then
                if (i == size(guesses)) then
                    write(*,*) "You failed!"
                    return
                end if
            end if
        end do

        write(*,*) "Congratulations!"
    end subroutine

    integer(c_int) function compare(a,b) bind(c)
        integer(c_int), intent(in) :: a, b
        compare = a - b
    end function

    ! see also https://stackoverflow.com/questions/20941575/sorting-in-fortran-undefined-reference-to-qsort
    subroutine qsort_example
        integer(c_int), target :: values(6)
        type(c_ptr) :: ptr

        print '("> qsort example")'

        values = [40, 10, 100, 90, 20, 25]
        write(*,"(6(I0,:,X))") values
        call c_qsort(c_loc(values(1)),6_c_size_t,c_sizeof(values(1)),c_funloc(compare))
        write(*,"(6(I0,:,X))") values
    end subroutine
end program


    Program zgebrd_example

!     ZGEBRD Example Program Text

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

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgebrd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, lda, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), taup(:), tauq(:), work(:)
      Real (Kind=dp), Allocatable :: d(:), e(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: min
!     .. Executable Statements ..
      Write (nout, *) 'ZGEBRD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = 64*(m+n)
      Allocate (a(lda,n), taup(n), tauq(n), work(lwork), d(n), e(n-1))

!     Read A from data file

      Read (nin, *)(a(i,1:n), i=1, m)

!     Reduce A to bidiagonal form

      Call zgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)

!     Print bidiagonal form

      Write (nout, *)
      Write (nout, *) 'Diagonal'
      Write (nout, 100) d(1:min(m,n))
      If (m>=n) Then
        Write (nout, *) 'Superdiagonal'
      Else
        Write (nout, *) 'Subdiagonal'
      End If
      Write (nout, 100) e(1:min(m,n)-1)

100   Format (1X, 8F9.4)
    End Program


!=============================================================================!
module fmax

      private :: fun
      integer, private :: n, kord = 5
      real, allocatable, private :: knot(:), bs(:)

      real, external :: BSDER

contains

!=============================================================================!
      function getval( nl, x, f, xmax)
!=============================================================================!
            implicit none

            integer :: nl, i, u, imax
            real :: getval, x(nl), f(nl), xmax
!=============================================================================!
            n = nl

            allocate( knot(n+kord), bs(n) )
            call BSNAK( n, x, kord, knot )
            call BSINT( n, x, f, kord, knot, bs )

            getval = BSDER( 0, xmax, kord, knot, n, bs )

            deallocate( knot, bs )

            return
      end function getval

!=============================================================================!
      subroutine fun( x, g, d )
!=============================================================================!
            implicit none

            real :: x, f, g, d
!=============================================================================!

!.... maximum value of function f

            f = BSDER( 0, x, kord, knot, n, bs )
            g = BSDER( 1, x, kord, knot, n, bs )
            d = BSDER( 2, x, kord, knot, n, bs )

            return
      end subroutine fun

!=============================================================================!
      function findmax( nl, x, f, xmax)
!=============================================================================!
            implicit none

            integer :: nl, i, u, imax
            real :: findmax, x(nl), f(nl), xmax

            real, external :: RTSAFE
!=============================================================================!
            n = nl

            allocate( knot(n+kord), bs(n) )
            call BSNAK( n, x, kord, knot )
            call BSINT( n, x, f, kord, knot, bs )

            do i = 1, n-1
              if ( f(i+1) .lt. f(i) ) goto 10
            end do
            write(*,*) 'Error in findmax'
            findmax = 1.0
            goto 20

10          continue
            imax = i
            xmax = RTSAFE( fun, x(i-2), x(i+2), 1.0e-14 )
            findmax = BSDER( 0, xmax, kord, knot, n, bs )

20          deallocate( knot, bs )

            return
      end function findmax

end module fmax


!  Tree.f90
!
!  FUNCTIONS/SUBROUTINES exported from Tree.dll:
!  Tree - subroutine
!
subroutine Tree(n,aa,xx,yy)

  ! Expose subroutine Tree to users of this DLL
  !
  !DEC$ ATTRIBUTES C,DLLEXPORT::Tree
  !DEC$ ATTRIBUTES REFERENCE:: n,aa,xx,yy

  ! Variables
    implicit none
    interface
    function ifs(x,y,a1,b1,c1,d1,e1,f1)
    implicit none
     real x,y,a1,b1,c1,d1,e1,f1
     real ifs(2)
    end
    end interface

    integer     n,ss
    real        p(n),xx(n),yy(n)
    real        aa(4,6),ans(2)
 ! Body of Tree
    ans=(0,0)
    call RANDOM_SEED()
    do ss = 1,n
    call RANDOM_NUMBER(p(ss))
    enddo
    do ss = 1,n
        if (p(ss)<=0.25) then
            ans=ifs(ans(1),ans(2),aa(1,1),aa(1,2),aa(1,3),aa(1,4),aa(1,5),aa(1,6))
        else
            if (p(ss)<=0.5) then
                ans=ifs(ans(1),ans(2),aa(2,1),aa(2,2),aa(2,3),aa(2,4),aa(2,5),aa(2,6))
            else
                if (p(ss)<=0.75) then
                    ans=ifs(ans(1),ans(2),aa(3,1),aa(3,2),aa(3,3),aa(3,4),aa(3,5),aa(3,6))
                else
                    ans=ifs(ans(1),ans(2),aa(4,1),aa(4,2),aa(4,3),aa(4,4),aa(4,5),aa(4,6))
                endif
            endif
        endif
        xx(ss)=ans(1)
        yy(ss)=ans(2)
    enddo
    end subroutine Tree

    function ifs(x,y,a1,b1,c1,d1,e1,f1)
    implicit none
     real  x,y,a1,b1,c1,d1,e1,f1
     real  ifs(2)
     ifs(1)=a1*x+b1*y+e1
     ifs(2)=c1*x+d1*y+f1
     return
    end function ifs


!*****************************************************************************************
!> author: Jacob Williams
!
!  B-plane and hyperbolic routines.

    module bplane_module

    use kind_module, only: wp
    use numbers_module
    use vector_module

    implicit none

    private

    public :: bplane
    public :: calculate_bplane_data
    public :: hyperbolic_turning_angle
    public :: vinf_to_energy

    !unit tests:
    public :: bplane_test

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute B-plane parameters from position and velocity.
!
!# References
!  1. W. Kizner, "A method of describing miss distances for lunar and interplanetary trajectories",
!     Planetary and Space Science, Volume 7, July 1961.
!  2. W. Kizner, "[Some orbital elements useful in space trajectory calculations](http://www.dtic.mil/dtic/tr/fulltext/u2/263968.pdf)",
!     JPL Technical Release No. 34-84, July 25, 1960.
!  3. A. B. Sergeyevsky, G. C. Snyder, R. A. Cunniff,
!     "[Interplanetary Mission Design Handbook, Volume I, Part 2](http://ntrs.nasa.gov/archive/nasa/casi.ntrs.nasa.gov/19840010158.pdf)",
!     JPL Publication 82-43, September 15, 1983.
!  4. [B-Plane Targeting](http://www.agi.com/resources/help/online/stk/10.1/index.html?page=source%2Fextfile%2Fgator%2Feq-bplane.htm)

    subroutine bplane(mu,rv,vinfvec,bmag,theta,BdotT,BdotR,status_ok)

    implicit none

    real(wp),intent(in)               :: mu        !! central body grav parameter \( (km^3/s^2) \)
    real(wp),dimension(6),intent(in)  :: rv        !! state vector (km,km/s)
    real(wp),dimension(3),intent(out) :: vinfvec   !! incoming V-infinity vector (km/s)
    real(wp),intent(out)              :: bmag      !! magnitude of B vector (km)
    real(wp),intent(out)              :: theta     !! aim point orientation [rad]
    real(wp),intent(out)              :: BdotT     !! \( \mathbf{B} \cdot \mathbf{T} \) (km)
    real(wp),intent(out)              :: BdotR     !! \( \mathbf{B} \cdot \mathbf{R} \) (km)
    logical,intent(out)               :: status_ok !! false if there were errors (non-hyperbolic or degenerate state)

    !local variables:
    real(wp),dimension(3) :: r,v,h,evec,bvec,tvec,ehat,hhat,hehat,Shat,That,Rhat,Bhat
    real(wp) :: rmag,vmag,vinf2,rdv,vmag2,a,alpha,sd2,cd2,ct,st,vinf,e

    status_ok = .true.

    r         = rv(1:3)
    v         = rv(4:6)
    h         = cross(r,v)
    hhat      = unit(h)

    if (all(hhat==zero)) then
        write(*,*) 'error: degenerate state.'
        status_ok = .false.
        return
    end if

    rdv       = dot_product(r,v)
    rmag      = norm2(r)
    vmag      = norm2(v)
    vmag2     = vmag*vmag
    vinf2     = vmag2 - two*mu/rmag
    vinf      = sqrt(vinf2)                     ! magnitude of v-infinity vector
    evec      = cross(v,h)/mu - r/rmag          ! eccentricity vector
    e         = norm2(evec)                     ! eccentricity

    if (e<=one) then
        write(*,*) 'error: state is not hyperbolic.'
        status_ok = .false.
        return
    end if

    ehat      = evec/e                          ! eccentricity unit vector
    a         = one / (two/rmag - vmag2/mu)     ! semi-major axis
    hehat     = cross(hhat,ehat)                ! h x e unit vector
    sd2       = one/e                           ! sin(delta/2)
    cd2       = sqrt(one-sd2*sd2)               ! cos(delta/2)
    Shat      = cd2*hehat + sd2*ehat            ! incoming vinf unit vector
    !Shat     = cd2*hehat - sd2*ehat            ! outgoing vinf unit vector
    That      = ucross(Shat,[zero, zero, one])  ! here we define Tvec relative to the Z-axis of
                                                ! the frame in which the state is defined

    if (all(That==zero)) then
        write(*,*) 'error: vinf vector is parallel to z-axis.'
        status_ok = .false.
        return
    end if

    Rhat      = cross(Shat,That)             ! Eqn 1 in [1]
    Bhat      = ucross(Shat,h)
    ct        = dot_product(Bhat,That)       ! cos(theta)
    st        = dot_product(Bhat,Rhat)       ! sin(theta)

    !outputs:
    Bmag      = abs(a)*sqrt( e*e - one )     ! magnitude of B vector
    theta     = atan2(st,ct)                 ! aim point orientation
    vinfvec   = vinf * Shat                  ! incoming vinf vector
    BdotT     = bmag*ct                      ! B dot T
    BdotR     = bmag*st                      ! B dot R

    end subroutine bplane
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute B-plane parameters from position and velocity -- alternate version.
!
!### See also
!  * [[bplane]]
!
!### Reference
!  * This one is based on the algorithm in GMAT: GmatCalcUtil::CalculateBPlaneData

    subroutine calculate_bplane_data(mu,state,bdotr,bdott,bmag,theta,istat)

    implicit none

    real(wp),intent(in)              :: mu     !! central body grav parameter \( (km^3/s^2) \)
    real(wp),dimension(6),intent(in) :: state  !! state vector (km,km/s)
    real(wp),intent(out)             :: bdotr  !! \( \mathbf{B} \cdot \mathbf{R} \) (km)
    real(wp),intent(out)             :: bdott  !! \( \mathbf{B} \cdot \mathbf{T} \) (km)
    real(wp),intent(out)             :: bmag   !! magnitude of B vector (km)
    real(wp),intent(out)             :: theta  !! aim point orientation [rad]
    integer,intent(out)              :: istat  !! status flag:
                                               !!
                                               !! * 0 if no errors.
                                               !! * -1 if state is not hyperbolic

    real(wp),dimension(3) :: r        !! position vector
    real(wp),dimension(3) :: v        !! velocity vector
    real(wp),dimension(3) :: evec     !! eccentricity vector
    real(wp),dimension(3) :: hvec     !! angular momentum vector
    real(wp),dimension(3) :: nvec     !! orbit normal vector
    real(wp),dimension(3) :: svec     !! incoming asymptote
    real(wp),dimension(3) :: bvec     !! B vector
    real(wp),dimension(3) :: tvec     !! T vector
    real(wp),dimension(3) :: rvec     !! R vector
    real(wp)              :: rmag     !! magnitude of `r`
    real(wp)              :: vmag     !! magnitude of `v`
    real(wp)              :: e        !! eccentricity
    real(wp)              :: hmag     !! magnitude of `hvec` vector
    real(wp)              :: b        !! semiminor axis
    real(wp)              :: oneovere !! 1/e
    real(wp)              :: temp

    r    = state(1:3)
    v    = state(4:6)
    hvec = cross(r, v)
    rmag = norm2(r)
    vmag = norm2(v)
    evec = cross(v,hvec)/mu - r/rmag
    e    = norm2(evec)

    if (e <= 1.0) then ! not hyperbolic
        write(*,*) 'error: state is not hyperbolic.'
        istat    = -1
        bdotr    = 0.0_wp
        bdott    = 0.0_wp
        bmag     = 0.0_wp
        theta    = 0.0_wp
    else
        istat    = 0
        evec     = unit(evec)
        hmag     = norm2(hvec)
        hvec     = unit(hvec)
        nvec     = cross(hvec, evec)
        b        = (hmag*hmag) / (mu * sqrt(e*e - 1.0_wp))
        oneovere = 1.0_wp/e
        temp     = sqrt(1.0_wp - oneovere*oneovere)
        svec     = (evec/e) + (temp*nvec)
        bvec     = b * (temp * evec - oneovere*nvec)
        tvec     = [svec(2), -svec(1), 0.0_wp] / sqrt(svec(1)*svec(1) + svec(2)*svec(2))
        rvec     = cross(svec, tvec)
        bdott    = dot_product(bvec, tvec)
        bdotr    = dot_product(bvec, rvec)
        bmag     = sqrt(bdott*bdott + bdotr*bdotr)
        theta    = atan(bdotr, bdott)
    end if

    end subroutine calculate_bplane_data
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the incoming and/or outgoing v-infinity vectors, given
!  the position and velocity of a hyperbola.
!
!@note This is for testing the other routines.

    subroutine compute_vinf_vectors(mu,rv,vinfin,vinfout)

    implicit none

    real(wp),intent(in)                        :: mu      !! central body gravitational parameter
    real(wp),dimension(6),intent(in)           :: rv      !! position,velocity vector
    real(wp),dimension(3),intent(out),optional :: vinfin  !! incoming v-infinity vector
    real(wp),dimension(3),intent(out),optional :: vinfout !! outgoing v-infinity vector

    real(wp),dimension(3) :: h,e,p,q,r,v
    real(wp) :: rmag,vmag,vinfmag,emag,qmag,cbeta,sbeta

    if (present(vinfin) .or. present(vinfout)) then
        r       = rv(1:3)
        v       = rv(4:6)
        rmag    = norm2(r)
        vmag    = norm2(v)
        h       = cross(r,v)
        q       = cross(v,h)
        vinfmag = sqrt(vmag*vmag-two*mu/rmag)
        e       = q/mu-r/rmag
        emag    = norm2(e)
        q       = cross(h,e)
        qmag    = norm2(q)
        cbeta   = one/emag
        sbeta   = sqrt(one-cbeta*cbeta)
        p       = e/emag
        q       = q/qmag
        if (present(vinfin))  vinfin  = vinfmag*( cbeta*p+sbeta*q)
        if (present(vinfout)) vinfout = vinfmag*(-cbeta*p+sbeta*q)
    end if

    end subroutine compute_vinf_vectors
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/6/2016
!
!  Compute the hyperbolic turning angle from the eccentricity.

    pure function hyperbolic_turning_angle(e) result(delta)

    implicit none

    real(wp),intent(in) :: e       !! eccentricity [--]
    real(wp)            :: delta   !! turning angle [rad]

    delta = two*asin(one/e)

    end function hyperbolic_turning_angle
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/6/2016
!
!  Convert V-infinity magnitude to energy.

    pure function vinf_to_energy(vinfmag) result(energy)

    implicit none

    real(wp),intent(in) :: vinfmag  !! \(v^{\infty} \) vector magnitude [km/s]
    real(wp)            :: energy   !! two-body orbital energy [km^2/s^2]

    energy = (vinfmag**2)/two

    end function vinf_to_energy
!*****************************************************************************************

!*****************************************************************************************
!>
!  Unit test for [[bplane_module]].

    subroutine bplane_test()

    implicit none

    real(wp),dimension(3) :: vinfvec
    real(wp) :: bmag,theta,BdotT,BdotR,bmag2,theta2,BdotT2,BdotR2
    logical :: status_ok
    integer :: istat

    real(wp),parameter :: mu = 0.398600436233000e+06_wp  !! grav. param. for earth \( (km^2/s^2) \)
    real(wp),dimension(6),parameter :: rv = [ -1.518170076605391E+04_wp, &
                                               1.518170076605392E+04_wp, &
                                               2.147016712324346E+04_wp, &
                                              -4.613927243557805E+00_wp, &
                                              -2.352686048227026E+00_wp, &
                                               1.598938983116768E+00_wp  ] !! example hyperbolic state

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' bplane_test'
    write(*,*) '---------------'
    write(*,*) ''

    call compute_vinf_vectors(mu,rv,vinfin=vinfvec)

    write(*,*) 'vinfvec(1) =' , vinfvec(1)
    write(*,*) 'vinfvec(2) =' , vinfvec(2)
    write(*,*) 'vinfvec(3) =' , vinfvec(3)

    call bplane(mu,rv,vinfvec,bmag,theta,BdotT,BdotR,status_ok)

    write(*,*) ''
    write(*,*) 'vinfvec(1) =' , vinfvec(1)
    write(*,*) 'vinfvec(2) =' , vinfvec(2)
    write(*,*) 'vinfvec(3) =' , vinfvec(3)
    write(*,*) 'bmag       =' , bmag
    write(*,*) 'theta      =' , theta
    write(*,*) 'BdotT      =' , BdotT
    write(*,*) 'BdotR      =' , BdotR

    call calculate_bplane_data(mu,rv,BdotR2,BdotT2,bmag2,theta2,istat)
    write(*,*) ''
    write(*,*) 'Alternate version:'
    write(*,*) ''
    write(*,*) 'bmag       =' , bmag2
    write(*,*) 'theta      =' , theta2
    write(*,*) 'BdotT      =' , BdotT2
    write(*,*) 'BdotR      =' , BdotR2

    write(*,*) ''
    write(*,*) 'Difference:'
    write(*,*) ''
    write(*,*) 'bmag       =' , bmag2 - bmag
    write(*,*) 'theta      =' , theta2 - theta
    write(*,*) 'BdotT      =' , BdotT2 - BdotT
    write(*,*) 'BdotR      =' , BdotR2 - BdotR

    end subroutine bplane_test
!*****************************************************************************************

!*****************************************************************************************
    end module bplane_module
!*****************************************************************************************


      SUBROUTINE HSTCSP (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,
     1                   BDD,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C     HSTCSP SOLVES THE STANDARD FIVE-POINT FINITE DIFFERENCE
C     APPROXIMATION ON A STAGGERED GRID TO THE MODIFIED HELMHOLTZ EQUATI
C     SPHERICAL COORDINATES ASSUMING AXISYMMETRY (NO DEPENDENCE ON
C     LONGITUDE)
C
C                  (1/R**2)(D/DR)(R**2(DU/DR)) +
C
C       1/(R**2*SIN(THETA))(D/DTHETA)(SIN(THETA)(DU/DTHETA)) +
C
C            (LAMBDA/(R*SIN(THETA))**2)U  =  F(THETA,R)
C
C     WHERE THETA IS COLATITUDE AND R IS THE RADIAL COORDINATE.
C     THIS TWO-DIMENSIONAL MODIFIED HELMHOLTZ EQUATION RESULTS FROM
C     THE FOURIER TRANSFORM OF THE THREE-DIMENSIONAL POISSON EQUATION.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C
C            * * * * * *   ON INPUT    * * * * * *
C
C   INTL
C     = 0  ON INITIAL ENTRY TO HSTCSP OR IF ANY OF THE ARGUMENTS
C          C, D, N, OR NBDCND ARE CHANGED FROM A PREVIOUS CALL
C
C     = 1  IF C, D, N, AND NBDCND ARE ALL UNCHANGED FROM PREVIOUS
C          CALL TO HSTCSP
C
C     NOTE:  A CALL WITH INTL = 0 TAKES APPROXIMATELY 1.5 TIMES AS MUCH
C            TIME AS A CALL WITH INTL = 1.  ONCE A CALL WITH INTL = 0
C            HAS BEEN MADE THEN SUBSEQUENT SOLUTIONS CORRESPONDING TO
C            DIFFERENT F, BDA, BDB, BDC, AND BDD CAN BE OBTAINED
C            FASTER WITH INTL = 1 SINCE INITIALIZATION IS NOT REPEATED.
C
C   A,B
C     THE RANGE OF THETA (COLATITUDE), I.E. A .LE. THETA .LE. B.  A
C     MUST BE LESS THAN B AND A MUST BE NON-NEGATIVE.  A AND B ARE IN
C     RADIANS.  A = 0 CORRESPONDS TO THE NORTH POLE AND B = PI
C     CORRESPONDS TO THE SOUTH POLE.
C
C                  * * *  IMPORTANT  * * *
C
C     IF B IS EQUAL TO PI, THEN B MUST BE COMPUTED USING THE STATEMENT
C
C     B = PIMACH(DUM)
C
C     THIS INSURES THAT B IN THE USER"S PROGRAM IS EQUAL TO PI IN THIS
C     PROGRAM WHICH PERMITS SEVERAL TESTS OF THE INPUT PARAMETERS THAT
C     OTHERWISE WOULD NOT BE POSSIBLE.
C
C                  * * * * * * * * * * * *
C
C   M
C     THE NUMBER OF GRID POINTS IN THE INTERVAL (A,B).  THE GRID POINTS
C     IN THE THETA-DIRECTION ARE GIVEN BY THETA(I) = A + (I-0.5)DTHETA
C     FOR I=1,2,...,M WHERE DTHETA =(B-A)/M.  M MUST BE GREATER THAN 4.
C
C   MBDCND
C     INDICATES THE TYPE OF BOUNDARY CONDITIONS AT THETA = A AND
C     THETA = B.
C
C     = 1  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THETA = B.
C          (SEE NOTES 1, 2 BELOW)
C
C     = 2  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THE DERIVATIVE
C          OF THE SOLUTION WITH RESPECT TO THETA IS SPECIFIED AT
C          THETA = B (SEE NOTES 1, 2 BELOW).
C
C     = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = A (SEE NOTES 1, 2 BELOW) AND THETA = B.
C
C     = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = A (SEE NOTES 1, 2 BELOW) AND THE
C          SOLUTION IS SPECIFIED AT THETA = B.
C
C     = 5  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND THE
C          SOLUTION IS SPECIFIED AT THETA = B. (SEE NOTE 2 BELOW)
C
C     = 6  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND THE
C          DERIVATIVE OF THE SOLUTION WITH RESPECT TO THETA IS
C          SPECIFIED AT THETA = B (SEE NOTE 2 BELOW).
C
C     = 7  IF THE SOLUTION IS SPECIFIED AT THETA = A AND THE
C          SOLUTION IS UNSPECIFIED AT THETA = B = PI.
C
C     = 8  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO
C          THETA IS SPECIFIED AT THETA = A (SEE NOTE 1 BELOW)
C          AND THE SOLUTION IS UNSPECIFIED AT THETA = B = PI.
C
C     = 9  IF THE SOLUTION IS UNSPECIFIED AT THETA = A = 0 AND
C          THETA = B = PI.
C
C     NOTES:  1.  IF A = 0, DO NOT USE MBDCND = 1,2,3,4,7 OR 8,
C                 BUT INSTEAD USE MBDCND = 5, 6, OR 9.
C
C             2.  IF B = PI, DO NOT USE MBDCND = 1,2,3,4,5 OR 6,
C                 BUT INSTEAD USE MBDCND = 7, 8, OR 9.
C
C             WHEN A = 0  AND/OR B = PI THE ONLY MEANINGFUL BOUNDARY
C             CONDITION IS DU/DTHETA = 0.  (SEE D. GREENSPAN, 'NUMERICAL
C             ANALYSIS OF ELLIPTIC BOUNDARY VALUE PROBLEMS,' HARPER AND
C             ROW, 1965, CHAPTER 5.)
C
C   BDA
C     A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C     VALUES (IF ANY) OF THE SOLUTION AT THETA = A.  WHEN
C     MBDCND = 1, 2, OR 7,
C
C              BDA(J) = U(A,R(J)) ,              J=1,2,...,N.
C
C     WHEN MBDCND = 3, 4, OR 8,
C
C              BDA(J) = (D/DTHETA)U(A,R(J)) ,    J=1,2,...,N.
C
C     WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A DUMMY VARIABLE.
C
C   BDB
C     A ONE-DIMENSIONAL ARRAY OF LENGTH N THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT THETA = B.  WHEN MBDCND = 1, 4, OR 5,
C
C              BDB(J) = U(B,R(J)) ,              J=1,2,...,N.
C
C     WHEN MBDCND = 2,3, OR 6,
C
C              BDB(J) = (D/DTHETA)U(B,R(J)) ,    J=1,2,...,N.
C
C     WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A DUMMY VARIABLE.
C
C   C,D
C     THE RANGE OF R , I.E. C .LE. R .LE. D.
C     C MUST BE LESS THAN D.  C MUST BE NON-NEGATIVE.
C
C   N
C     THE NUMBER OF UNKNOWNS IN THE INTERVAL (C,D).  THE UNKNOWNS IN
C     THE R-DIRECTION ARE GIVEN BY R(J) = C + (J-0.5)DR,
C     J=1,2,...,N, WHERE DR = (D-C)/N.  N MUST BE GREATER THAN 4.
C
C   NBDCND
C     INDICATES THE TYPE OF BOUNDARY CONDITIONS AT R = C
C     AND R = D.
C
C     = 1  IF THE SOLUTION IS SPECIFIED AT R = C AND R = D.
C
C     = 2  IF THE SOLUTION IS SPECIFIED AT R = C AND THE DERIVATIVE
C          OF THE SOLUTION WITH RESPECT TO R IS SPECIFIED AT
C          R = D. (SEE NOTE 1 BELOW)
C
C     = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C          SPECIFIED AT R = C AND R = D.
C
C     = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R IS
C          SPECIFIED AT R = C AND THE SOLUTION IS SPECIFIED AT
C          R = D.
C
C     = 5  IF THE SOLUTION IS UNSPECIFIED AT R = C = 0 (SEE NOTE 2
C          BELOW) AND THE SOLUTION IS SPECIFIED AT R = D.
C
C     = 6  IF THE SOLUTION IS UNSPECIFIED AT R = C = 0 (SEE NOTE 2
C          BELOW) AND THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO R
C          IS SPECIFIED AT R = D.
C
C     NOTE 1:  IF C = 0 AND MBDCND = 3,6,8 OR 9, THE SYSTEM OF EQUATIONS
C              TO BE SOLVED IS SINGULAR.  THE UNIQUE SOLUTION IS
C              DETERMINED BY EXTRAPOLATION TO THE SPECIFICATION OF
C              U(THETA(1),C).  BUT IN THESE CASES THE RIGHT SIDE OF THE
C              SYSTEM WILL BE PERTURBED BY THE CONSTANT PERTRB.
C
C     NOTE 2:  NBDCND = 5 OR 6 CANNOT BE USED WITH MBDCND = 1, 2, 4, 5,
C              OR 7 (THE FORMER INDICATES THAT THE SOLUTION IS
C              UNSPECIFIED AT R = 0; THE LATTER INDICATES THAT THE
C              SOLUTION IS SPECIFIED).  USE INSTEAD NBDCND = 1 OR 2.
C
C   BDC
C     A ONE DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT R = C.   WHEN NBDCND = 1 OR 2,
C
C              BDC(I) = U(THETA(I),C) ,              I=1,2,...,M.
C
C     WHEN NBDCND = 3 OR 4,
C
C              BDC(I) = (D/DR)U(THETA(I),C),         I=1,2,...,M.
C
C     WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A DUMMY VARIABLE.
C
C   BDD
C     A ONE-DIMENSIONAL ARRAY OF LENGTH M THAT SPECIFIES THE BOUNDARY
C     VALUES OF THE SOLUTION AT R = D.  WHEN NBDCND = 1 OR 4,
C
C              BDD(I) = U(THETA(I),D) ,              I=1,2,...,M.
C
C     WHEN NBDCND = 2 OR 3,
C
C              BDD(I) = (D/DR)U(THETA(I),D) ,        I=1,2,...,M.
C
C     WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A DUMMY VARIABLE.
C
C   ELMBDA
C     THE CONSTANT LAMBDA IN THE MODIFIED HELMHOLTZ EQUATION.  IF
C     LAMBDA IS GREATER THAN 0, A SOLUTION MAY NOT EXIST.  HOWEVER,
C     HSTCSP WILL ATTEMPT TO FIND A SOLUTION.
C
C   F
C     A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C     SIDE OF THE MODIFIED HELMHOLTZ EQUATION.  FOR I=1,2,...,M AND
C     J=1,2,...,N
C
C              F(I,J) = F(THETA(I),R(J)) .
C
C     F MUST BE DIMENSIONED AT LEAST M X N.
C
C   IDIMF
C     THE ROW (OR FIRST) DIMENSION OF THE ARRAY F AS IT APPEARS IN THE
C     PROGRAM CALLING HSTCSP.  THIS PARAMETER IS USED TO SPECIFY THE
C     VARIABLE DIMENSION OF F.  IDIMF MUST BE AT LEAST M.
C
C   W
C     A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C     WORK SPACE.  WITH K = INT(LOG2(N))+1 AND L = 2**(K+1), W MAY
C     REQUIRE UP TO (K-2)*L+K+MAX(2N,6M)+4(N+M)+5 LOCATIONS.  THE
C     ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY HSTCSP AND IS
C     RETURNED IN THE LOCATION W(1).
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C   F
C     CONTAINS THE SOLUTION U(I,J) OF THE FINITE DIFFERENCE
C     APPROXIMATION FOR THE GRID POINT (THETA(I),R(J)) FOR
C     I=1,2,...,M, J=1,2,...,N.
C
C   PERTRB
C     IF A COMBINATION OF PERIODIC, DERIVATIVE, OR UNSPECIFIED
C     BOUNDARY CONDITIONS IS SPECIFIED FOR A POISSON EQUATION
C     (LAMBDA = 0), A SOLUTION MAY NOT EXIST.  PERTRB IS A CON-
C     STANT, CALCULATED AND SUBTRACTED FROM F, WHICH ENSURES
C     THAT A SOLUTION EXISTS.  HSTCSP THEN COMPUTES THIS
C     SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO THE
C     ORIGINAL APPROXIMATION.  THIS SOLUTION PLUS ANY CONSTANT IS ALSO
C     A SOLUTION; HENCE, THE SOLUTION IS NOT UNIQUE.  THE VALUE OF
C     PERTRB SHOULD BE SMALL COMPARED TO THE RIGHT SIDE F.
C     OTHERWISE, A SOLUTION IS OBTAINED TO AN ESSENTIALLY DIFFERENT
C     PROBLEM.  THIS COMPARISON SHOULD ALWAYS BE MADE TO INSURE THAT
C     A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C   IERROR
C     AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C     EXCEPT FOR NUMBERS 0 AND 10, A SOLUTION IS NOT ATTEMPTED.
C
C     =  0  NO ERROR
C
C     =  1  A .LT. 0 OR B .GT. PI
C
C     =  2  A .GE. B
C
C     =  3  MBDCND .LT. 1 OR MBDCND .GT. 9
C
C     =  4  C .LT. 0
C
C     =  5  C .GE. D
C
C     =  6  NBDCND .LT. 1 OR NBDCND .GT. 6
C
C     =  7  N .LT. 5
C
C     =  8  NBDCND = 5 OR 6 AND MBDCND = 1, 2, 4, 5, OR 7
C
C     =  9  C .GT. 0 AND NBDCND .GE. 5
C
C     = 10  ELMBDA .GT. 0
C
C     = 11  IDIMF .LT. M
C
C     = 12  M .LT. 5
C
C     = 13  A = 0 AND MBDCND =1,2,3,4,7 OR 8
C
C     = 14  B = PI AND MBDCND .LE. 6
C
C     = 15  A .GT. 0 AND MBDCND = 5, 6, OR 9
C
C     = 16  B .LT. PI AND MBDCND .GE. 7
C
C     = 17  LAMBDA .NE. 0 AND NBDCND .GE. 5
C
C     SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C     INCORRECT CALL TO HSTCSP, THE USER SHOULD TEST IERROR AFTER
C     THE CALL.
C
C   W
C     W(1) CONTAINS THE REQUIRED LENGTH OF W.  ALSO  W CONTAINS
C     INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF HSTCSP
C     WILL BE CALLED AGAIN WITH INTL = 1.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C    DIMENSION OF   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C    ARGUMENTS      W(SEE ARGUMENT LIST)
C
C    LATEST         JUNE 1979
C    REVISION
C
C    SUBPROGRAMS    HSTCSP,HSTCS1,BLKTRI,BLKTR1,INDXA,INDXB,INDXC,
C    REQUIRED       PROD,PRODP,CPROD,CPRODP,PPADD,PSGF,BSRH,PPSGF,
C                   PPSPF,COMPB,TEVLS,EPMACH,STORE
C
C    SPECIAL        NONE
C    CONDITIONS
C
C    COMMON         CBLKT,VALU1
C    BLOCKS
C
C    I/O            NONE
C
C    PRECISION      SINGLE
C
C    SPECIALIST     ROLAND SWEET
C
C    LANGUAGE       FORTRAN
C
C    HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN MAY, 1977
C
C    ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE-DIFFERENCE
C                   EQUATIONS, INCORPORATES BOUNDARY DATA, ADJUSTS THE
C                   RIGHT SIDE WHEN THE SYSTEM IS SINGULAR AND CALLS
C                   BLKTRI WHICH SOLVES THE LINEAR SYSTEM OF EQUATIONS.
C
C    SPACE          5269(DECIMAL) = 12225(OCTAL) LOCATIONS ON THE
C    REQUIRED       NCAR CONTROL DATA 7600
C
C    TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C    ACCURACY       7600 FOR SUBROUTINE HSTCSP IS ROUGHLY PROPORTIONAL
C                   TO M*N*LOG2(N), BUT DEPENDS ON THE INPUT PARAMETER
C                   INTL.  SOME VALUES ARE LISTED IN THE TABLE BELOW.
C                      THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                   OF NO MORE THAN FOUR SIGNIFICANT DIGITS FOR N AND M
C                   AS LARGE AS 64.  MORE DETAILED INFORMATION ABOUT
C                   ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                   SUBROUTINE BLKTRI WHICH IS THE ROUTINE THAT
C                   ACTUALLY SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                      M(=N)     INTL      MBDCND(=NBDCND)     T(MSECS)
C                      -----     ----      ---------------     --------
C
C                       32        0              1-6             132
C                       32        1              1-6              88
C                       64        0              1-6             546
C                       64        1              1-6             380
C
C    PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                   AN APPROXIMATE MACHINE EPSILON IS COMPUTED IN
C                   FUNCTION PIMACH.
C
C    REQUIRED       COS,SIN,CABS,CSQRT
C    RESIDENT
C    ROUTINES
C
C    REFERENCE      SWARZTRAUBER, P.N., "A DIRECT METHOD FOR THE
C                   DISCRETE SOLUTION OF SEPARABLE ELLIPTIC EQUATIONS,"
C                   SIAM J. NUMER. ANAL. 11(1974), PP. 1136-1150.
C                   ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                   PP. 171-182.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       F(IDIMF,1) ,BDA(1)     ,BDB(1)     ,BDC(1)     ,
     1                BDD(1)     ,W(1)
      PI = PIMACH(DUM)
C
C     CHECK FOR INVALID INPUT PARAMETERS
C
      IERROR = 0
      IF (A.LT.0. .OR. B.GT.PI) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LT.1 .OR. MBDCND.GT.9) IERROR = 3
      IF (C .LT. 0.) IERROR = 4
      IF (C .GE. D) IERROR = 5
      IF (NBDCND.LT.1 .OR. NBDCND.GT.6) IERROR = 6
      IF (N .LT. 5) IERROR = 7
      IF ((NBDCND.EQ.5 .OR. NBDCND.EQ.6) .AND. (MBDCND.EQ.1 .OR.
     1    MBDCND.EQ.2 .OR. MBDCND.EQ.4 .OR. MBDCND.EQ.5 .OR.
     2                                                     MBDCND.EQ.7))
     3    IERROR = 8
      IF (C.GT.0. .AND. NBDCND.GE.5) IERROR = 9
      IF (IDIMF .LT. M) IERROR = 11
      IF (M .LT. 5) IERROR = 12
      IF (A.EQ.0. .AND. MBDCND.NE.5 .AND. MBDCND.NE.6 .AND. MBDCND.NE.9)
     1    IERROR = 13
      IF (B.EQ.PI .AND. MBDCND.LE.6) IERROR = 14
      IF (A.GT.0. .AND. (MBDCND.EQ.5 .OR. MBDCND.EQ.6 .OR. MBDCND.EQ.9))
     1    IERROR = 15
      IF (B.LT.PI .AND. MBDCND.GE.7) IERROR = 16
      IF (ELMBDA.NE.0. .AND. NBDCND.GE.5) IERROR = 17
      IF (IERROR .NE. 0) GO TO 101
      IWBM = M+1
      IWCM = IWBM+M
      IWAN = IWCM+M
      IWBN = IWAN+N
      IWCN = IWBN+N
      IWSNTH = IWCN+N
      IWRSQ = IWSNTH+M
      IWWRK = IWRSQ+N
      IERR1 = 0
      CALL HSTCS1 (INTL,A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,
     1             ELMBDA,F,IDIMF,PERTRB,IERR1,W,W(IWBM),W(IWCM),
     2             W(IWAN),W(IWBN),W(IWCN),W(IWSNTH),W(IWRSQ),W(IWWRK))
      W(1) = W(IWWRK)+FLOAT(IWWRK-1)
      IERROR = IERR1
  101 CONTINUE
      RETURN
      END


! Program to test SIGN intrinsic
program intrinsic_sign
   implicit none
   integer i, j
   real r, s

   i = 2
   j = 3
   if (sign (i, j) .ne. 2) call abort
   i = 4
   j = -5
   if (sign (i, j) .ne. -4) call abort
   i = -6
   j = 7
   if (sign (i, j) .ne. 6) call abort
   i = -8
   j = -9
   if (sign (i, j) .ne. -8) call abort
   r = 1
   s = 2
   if (sign (r, s) .ne. 1) call abort
   r = 1
   s = -2
   if (sign (r, s) .ne. -1) call abort
   s = 0
   if (sign (r, s) .ne. 1) call abort
   ! Will fail on machines which cannot represent negative zero.
   s = -s ! Negative zero
   if (sign (r, s) .ne. -1) call abort
end program