program time_array_multiply
    implicit none
    integer :: seed_size
    integer, allocatable :: seed(:)
    integer, parameter :: N = 500
    integer, parameter :: N_REPS = 10
    real :: a(N, N)
    real :: b(N, N)
    real :: c(N, N)
    integer :: r, i, j, alpha
    real :: tmp
    real :: t1, t2

    call random_seed(size=seed_size)
    allocate(seed(seed_size), source=0)
    call random_seed(put=seed)
    deallocate(seed)
    call random_number(a)
    call random_number(b)

    call cpu_time(t1)
    iaja: do r = 1, N_REPS
        do i = 1, N
            do j = 1, N
                tmp = 0.0
                do alpha = 1, N
                    tmp = tmp + a(i, alpha) * b(j, alpha)
                end do ! alpha
                c(i, j) = tmp
            end do ! j
        end do ! i
    end do iaja
    call cpu_time(t2)
    print '(a, es8.2, a)', "Contraction (i, *)(j, *) took ", (t2 - t1) / N_REPS, " s."

    call cpu_time(t1)
    iaaj: do r = 1, N_REPS
        do i = 1, N
            do j = 1, N
                tmp = 0.0
                do alpha = 1, N
                    tmp = tmp + a(i, alpha) * b(alpha, j)
                end do ! alpha
                c(i, j) = tmp
            end do ! j
        end do ! i
    end do iaaj
    call cpu_time(t2)
    print '(a, es8.2, a)', "Contraction (i, *)(*, j) took ", (t2 - t1) / N_REPS, " s."

    call cpu_time(t1)
    aija: do r = 1, N_REPS
        do i = 1, N
            do j = 1, N
                tmp = 0.0
                do alpha = 1, N
                    tmp = tmp + a(alpha, i) * b(j, alpha)
                end do ! alpha
                c(i, j) = tmp
            end do ! j
        end do ! i
    end do aija
    call cpu_time(t2)
    print '(a, es8.2, a)', "Contraction (*, i)(j, *) took ", (t2 - t1) / N_REPS, " s."

    call cpu_time(t1)
    aiaj: do r = 1, N_REPS
        do i = 1, N
            do j = 1, N
                tmp = 0.0
                do alpha = 1, N
                    tmp = tmp + a(alpha, i) * b(alpha, j)
                end do ! alpha
                c(i, j) = tmp
            end do ! j
        end do ! i
    end do aiaj
    call cpu_time(t2)
    print '(a, es8.2, a)', "Contraction (*, i)(*, j) took ", (t2 - t1) / N_REPS, " s."

    call cpu_time(t1)
    icrj: do r = 1, N_REPS
        do i = 1, N
            do j = 1, N
                c(i, j) = sum(a(i, :) * b(:, j))
            end do ! j
        end do ! i
    end do icrj
    call cpu_time(t2)
    print '(a, es8.2, a)', "Contraction (i, :)(:, j) took ", (t2 - t1) / N_REPS, " s."

    call cpu_time(t1)
    mat_mul: do r = 1, N_REPS
        c(:, :) = matmul(a(:, :), b(:, :))
    end do mat_mul
    call cpu_time(t2)
    print '(a, es8.2, a)', "With matmul (i, :)(:, j) took ", (t2 - t1) / N_REPS, " s."

end program time_array_multiply


	SUBROUTINE getgrid(Nx,Ny,Nz,Lx,Ly,Lz,pi,name_config,x,y,z,kx,ky,kz)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine gets grid points and fourier frequencies for a
	! pseudospectral simulation of the 2D nonlinear Klein-Gordon equation
	!
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*u^3
	!
	! The boundary conditions are u(x=-Lx*pi,y,z)=u(x=Lx*\pi,y,z),
	!	u(x,y=-Ly*pi,z)=u(x,y=Ly*pi,z),u(x,y,z=-Ly*pi)=u(x,y,z=Ly*pi),
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Ny				= number of modes in z - power of 2 for FFT
	!  pi				= 3.142....
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  Lz				= width of box in z direction
	! OUTPUT
	!
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	!  x				= x locations
	!  y				= y locations
	!  z				= z locations
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! OpenMP library
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)							:: Nx,Ny,Nz
	REAL(kind=8), INTENT(IN)							:: Lx,Ly,Lz,pi
	REAL(KIND=8), DIMENSION(1:NX), INTENT(OUT) 			:: x
	REAL(KIND=8), DIMENSION(1:NY), INTENT(OUT) 			:: y
	REAL(KIND=8), DIMENSION(1:NZ), INTENT(OUT) 			:: z
	COMPLEX(KIND=8), DIMENSION(1:NX), INTENT(OUT)		:: kx
	COMPLEX(KIND=8), DIMENSION(1:NY), INTENT(OUT)		:: ky
	COMPLEX(KIND=8), DIMENSION(1:NZ), INTENT(OUT)		:: kz
	CHARACTER*100, INTENT(OUT)							:: name_config
	INTEGER(kind=4)										:: i,j,k
	!$OMP PARALLEL
	!$OMP DO SCHEDULE(static)
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	!$OMP END DO
	kx(1+Nx/2)=0.0d0
	!$OMP DO SCHEDULE(static)
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
	DO i=1,Nx
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*Lx
	END DO
	!$OMP END DO

	!$OMP DO SCHEDULE(static)
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	!$OMP END DO
	ky(1+Ny/2)=0.0d0
	!$OMP DO SCHEDULE(static)
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
	DO j=1,Ny
		y(j)=(-1.0d0 + 2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)))*pi*Ly
	END DO
	!$OMP END DO

	!$OMP DO SCHEDULE(static)
	DO k=1,1+Nz/2
		kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	END DO
	!$OMP END DO
	kz(1+Nz/2)=0.0d0
	!$OMP DO SCHEDULE(static)
	DO k = 1,Nz/2 -1
		kz(k+1+Nz/2)=-kz(1-k+Nz/2)
	END DO
	!$OMP END DO
	!$OMP DO SCHEDULE(static)
	DO k=1,Nz
		z(k)=(-1.0d0 + 2.0d0*REAL(k-1,kind(0d0))/REAL(Nz,kind(0d0)))*pi*Lz
	END DO
	!$OMP END DO
	!$OMP END PARALLEL
	! Save x grid points in text format
	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)
	! Save y grid points in text format
	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)
	! Save z grid points in text format
	name_config = 'zcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO k=1,Nz
		WRITE(11,*) z(k)
	END DO
	CLOSE(11)

	END SUBROUTINE getgrid


!==============================================================================!
  function Math_Mod_Cross_Product(a, b)
!------------------------------------------------------------------------------!
!   This is a prototype of a small module which would contain some basic       !
!   mathematic and related functions.                                          !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real, dimension(3)             :: Math_Mod_Cross_Product
  real, dimension(3), intent(in) :: a, b
!==============================================================================!

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

  end function


      PROGRAM xdfpmin
C     driver for routine dfpmin
      INTEGER NDIM
      REAL GTOL
      PARAMETER(NDIM=2,GTOL=1.0E-4)
      COMMON /stats/ nfunc,ndfunc
      INTEGER iter,ndfunc,nfunc
      REAL fret,p(NDIM)
      EXTERNAL func,dfunc
      write(*,'(/1x,a)') 'True minimum is at (-2.0,+-0.89442719)'
      nfunc=0
      ndfunc=0
      p(1)=.1
      p(2)=4.2
      write(*,'(/1x,a,2(f7.4,a))') 'Starting vector: (',
     *     p(1),',',p(2),')'
      call dfpmin(p,NDIM,GTOL,iter,fret,func,dfunc)
      write(*,'(1x,a,i3)') 'Iterations:',iter
      write(*,'(1x,a,i3)') 'Func. evals:',nfunc
      write(*,'(1x,a,i3)') 'Deriv. evals:',ndfunc
      write(*,'(1x,a,2(f9.6,a))') 'Solution vector: (',
     *     p(1),',',p(2),')'
      write(*,'(1x,a,e14.6)') 'Func. value at solution',fret
      END
      REAL FUNCTION func(x)
      INTEGER ndfunc,nfunc
      COMMON /stats/ nfunc,ndfunc
      REAL x(*)
      nfunc=nfunc+1
      func=10.*(x(2)**2*(3.-x(1))-x(1)**2*(3.+x(1)))**2+(2.+x(1))**2/
     *     (1.+(2.+x(1))**2)
      END
      SUBROUTINE dfunc(x,df)
      INTEGER NMAX
      PARAMETER (NMAX=50)
      INTEGER ndfunc,nfunc
      COMMON /stats/ nfunc,ndfunc
      REAL x(*),df(NMAX)
      ndfunc=ndfunc+1
      df(1)=20.*(x(2)**2*(3.-x(1))-x(1)**2*(3.+x(1)))*(-x(2)**2-6.*
     *     x(1)-3.*x(1)**2)+2.*(2.+x(1))/(1.+(2.+x(1))**2)-
     *     2.*(2.+x(1))**3/(1.+(2.+x(1))**2)**2
      df(2)=40.*(x(2)**2*(3.-x(1))-x(1)**2*(3.+x(1)))*x(2)*(3.-x(1))
      return
      END

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


subroutine tri_solve(N,dl,d,du,b)
    implicit none

    integer N
    double precision, dimension(N) :: dl, d, du, b

    integer i
    double precision fact

    do i = 1,N-2
        if (abs(d(i)) .ne. 0) then
            fact = dl(i)/d(i)
            d(i+1) = d(i+1) - fact*du(i)
            b(i+1) = b(i+1) - fact*b(i)
        endif
        dl(i) = 0
    end do

111  format('b(',I3,') = ', 5E20.8)

    i = N-1
    if (abs(d(i)) .ne. 0) then
        fact = dl(i)/d(i)
        d(i+1) = d(i+1) - fact*du(i)
        b(i+1) = b(i+1) - fact*b(i)
    endif

    b(N) = b(N)/d(N)
    b(N-1) = (b(N-1) - du(N-1)*b(N))/d(N-1)
    do i = N-2,1,-1
        b(i) = (b(i) - du(i)*b(i+1) - dl(i)*b(i+2))/d(i)
    end do

end subroutine tri_solve


	FUNCTION PS_HANS  ( tc1, tc2, dwpc, itype )
C************************************************************************
C* PS_HANS								*
C*									*
C* This subroutine computes low, middle, and high elevation Haines 	*
C* Indices from TMPC and DWPC.						*
C*									*
C* PS_HANS ( TC1, TC2, DWPC, ITYPE )					*
C*									*
C* Input parameters:							*
C*	TC1		REAL		Temperature in Celsius		*
C*	TC2		REAL		Temperature in Celsius		*
C*	DWPC		REAL    	Dewpoint in Celsius		*
C*	ITYPE		INTEGER		Type of Haines index		*
C*					  1 = Low			*
C*					  2 = Middle			*
C*					  3 = High			*
C*									*
C* Output parameters:							*
C*	PS_HANS		REAL		Haines index			*
C**									*
C* Log:									*
C* T. Lee/SAIC		 6/03	Created					*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for missing data.
C
	IF  ( ( ERMISS ( tc1 ) ) .or. ( ERMISS ( tc2 ) ) .or.
     +	      ( ERMISS ( dwpc ) ) )  THEN
		PS_HANS = RMISSD
	  ELSE
C
C*	    Compute the Haines index.
C
	    IF  ( itype .eq. 1 )  THEN
		a = ( ( tc2  -  tc1  ) - 3. ) * (2./5.) + 1.
		b = ( ( tc1  - dwpc  ) - 5. ) * (2./5.) + 1.
	      ELSE IF ( itype .eq. 2 )  THEN
		a = ( ( tc1  -  tc2  ) - 5. ) * (2./6.) + 1.
		b = ( ( tc1  - dwpc  ) - 5. ) * (2./8.) + 1.
	      ELSE IF ( itype .eq. 3 )  THEN
		a = ( ( tc1  -  tc2  ) - 17.) * (2./5.) + 1.
		b = ( ( tc1  - dwpc  ) - 14.) * (2./7.) + 1.
 	    END IF
	    a = AMAX1 ( a, 0.9 )
	    a = AMIN1 ( a, 3.1 )
	    b = AMAX1 ( b, 0.9 )
	    b = AMIN1 ( b, 3.1 )
	    PS_HANS = a + b
	END IF
C*
	RETURN
	END


! { dg-do run }

module e_51_3_mod
contains
  subroutine init (Q, rows, cols)
    integer :: i, k, rows, cols
    double precision :: Q(rows,cols)
    do k = 1, cols
      do i = 1, rows
        Q(i,k) = 10 * i + k
      end do
    end do
  end subroutine

  subroutine check (P, Q, rows, cols)
    integer :: i, k, rows, cols
    double precision, parameter :: EPS = 0.00001
    double precision :: P(rows,cols), Q(rows,cols), diff
    do k = 1, cols
      do i = 1, rows
        diff = P(i,k) - Q(i,k)
        if (diff > EPS .or. -diff > EPS) call abort
      end do
    end do
  end subroutine

  subroutine gramSchmidt_ref (Q, rows, cols)
    integer :: i, k, rows, cols
    double precision :: Q(rows,cols), tmp
    do k = 1, cols
      tmp = 0.0d0
      do i = 1, rows
        tmp = tmp + (Q(i,k) * Q(i,k))
      end do
      tmp = 1.0d0 / sqrt (tmp)
      do i = 1, rows
        Q(i,k) = Q(i,k) * tmp
      end do
    end do
  end subroutine

  subroutine gramSchmidt (Q, rows, cols)
    integer :: i, k, rows, cols
    double precision :: Q(rows,cols), tmp
    !$omp target data map(Q)
      do k = 1, cols
        tmp = 0.0d0
        !$omp target map(tofrom: tmp)
          !$omp parallel do reduction(+:tmp)
          do i = 1, rows
            tmp = tmp + (Q(i,k) * Q(i,k))
          end do
        !$omp end target
        tmp = 1.0d0 / sqrt (tmp)
        !$omp target
          !$omp parallel do
          do i = 1, rows
            Q(i,k) = Q(i,k) * tmp
          end do
        !$omp end target
      end do
    !$omp end target data
  end subroutine
end module

program e_51_3
  use e_51_3_mod, only : init, check, gramSchmidt, gramSchmidt_ref
  integer :: cols, rows
  double precision, pointer :: P(:,:), Q(:,:)
  cols = 5
  rows = 5
  allocate (P(rows,cols), Q(rows,cols))
  call init (P, rows, cols)
  call init (Q, rows, cols)
  call gramSchmidt_ref (P, rows, cols)
  call gramSchmidt (Q, rows, cols)
  call check (P, Q, rows, cols)
  deallocate (P, Q)
end program


submodule(euler_interface_m) euler_prob_0006_m
    implicit none

contains

    module character(len=20) function euler0006()
        write (euler0006, "(i20)") ans(100)
    end function euler0006

    integer function ans(n)
        integer, intent(in) :: n
        integer :: i, sum_square, square_sum

        sum_square = 0; square_sum = 0
        do i = 1, n
            sum_square = sum_square + i**2
        end do
        square_sum = ((1 + n)*n/2)**2
        ans = square_sum - sum_square
    end function ans
end submodule euler_prob_0006_m


module day03_functions
  implicit none
  contains

  function most_common_bit(i, words) result(b)
    implicit none

    integer, intent(in) :: i
    integer, intent(in), dimension(:) :: words
    integer :: n, sum, count, b

    ! Count the number of 1s
    sum = 0
    count = size(words)
    do n = 1, count
      sum = sum + iand(ishft(words(n), -i), 1)
    end do

    ! The most common bit is 1 if there are at least (count / 2) of them
    if (2 * sum >= count) then
      b = 1
    else
      b = 0
    end if
  end function

  subroutine compute_rating(use_least, words, width, rating)
    integer, dimension(:), intent(in) :: words
    integer, dimension(:), allocatable :: remaining
    integer, intent(in) :: use_least, width
    integer :: i, n, b, count
    integer, intent(out) :: rating

    count = size(words)

    allocate(remaining(count))
    do n = 1, count
      remaining(n) = words(n)
    end do

    do i = width - 1, 0, -1
      b = ieor(most_common_bit(i, remaining), use_least)
      remaining = pack(remaining, iand(ishft(remaining, -i), 1) == b)
      if (size(remaining) <= 1) exit
    end do

    rating = remaining(1)
  end subroutine
end module

program day03
  use day03_functions
  implicit none

  integer, parameter :: count = 1000
  integer, parameter :: width = 12
  integer, dimension(count) :: xs
  integer :: ios, i, b, n, gamma_rate, epsilon_rate, oxygen_rating, co2_rating

  ! Read inputs line-by-line into xs
  open(1, file='resources/input.txt')
  do n = 1, count
    read(1, '(B32)', iostat=ios) xs(n)
    if (ios /= 0) exit
  end do
  close(1)

  ! Compute gamma rate
  gamma_rate = 0
  do i = 0, width - 1
    ! Update out gamma rate with this bit
    b = most_common_bit(i, xs)
    gamma_rate = ior(gamma_rate, ishft(b, i))
  end do

  ! Compute epsilon rate, which is just the bitwise negation of the gamma rate
  epsilon_rate = ieor(gamma_rate, (ishft(1, width) - 1))

  print *, 'Part 1:', gamma_rate * epsilon_rate

  ! Compute oxygen rating and co2 rating
  call compute_rating(0, xs, width, oxygen_rating)
  call compute_rating(1, xs, width, co2_rating)

  print *, 'Part 2:', oxygen_rating * co2_rating
end program day03


! { dg-do run }
!
! Test the vendor intrinsic (d)gamma, lgamma and algama/dlgama
! gamma is also part of the Fortran 2008 draft; lgamma is called
! log_gamma in the Fortran 2008 draft.
!
! PR fortran/32980
!
program gamma_test
implicit none
intrinsic :: gamma, lgamma, log_gamma
integer, parameter :: sp = kind(1.0)
integer, parameter :: dp = kind(1.0d0)

real(sp) :: rsp
real(dp) :: rdp

if (abs(gamma(1.0_sp)  - 1.0_sp) > tiny(1.0_sp)) call abort()
if (abs(gamma(1.0_dp)  - 1.0_dp) > tiny(1.0_dp)) call abort()
if (abs(dgamma(1.0_dp) - 1.0_dp) > tiny(1.0_dp)) call abort()

if (abs(lgamma(1.0_sp)) > tiny(1.0_sp)) call abort()
if (abs(lgamma(1.0_dp)) > tiny(1.0_dp)) call abort()
if (abs(log_gamma(1.0_sp)) > tiny(1.0_sp)) call abort()
if (abs(log_gamma(1.0_dp)) > tiny(1.0_dp)) call abort()
if (abs(algama(1.0_sp)) > tiny(1.0_sp)) call abort()
if (abs(dlgama(1.0_dp)) > tiny(1.0_dp)) call abort()
end program gamma_test


SUBROUTINE phi_linear_bottom(H,k,x,z,d,hx,hxx,int_kx,omega,time,grav,phix,phiz,phi,phit)
!
USE PRECISION
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,k,x,z,d,omega,time,grav,int_kx,hx,hxx
REAL(KIND=long), INTENT(OUT) :: phix,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   ! Local variables
REAL(KIND=long) :: kx, sinkx, coskx, temp1, temp2, temp3
!
kx=int_kx-omega*time
sinkx = sin(kx)
coskx = cos(kx)
!
temp1 = COSH(k*(z+d))/COSH(k*d)
temp3 = SINH(k*(z+d))/COSH(k*d)
temp2 = H*0.5d0*grav/omega
!
!phiz = temp2*(sinkx*temp1*k*tanh(k*(z+d)))
phiz = temp2*(-sinkx*temp3*k-hx*coskx*temp1*k)
!phix = temp2*k*coskx*temp1
phix = temp2*(-k*coskx*temp1+k*hx*sinkx*temp3-hxx*coskx*temp3)
!
IF(present(phit)) THEN
    !phit = -phix*omega/k !we assume that k/=0
    phit = temp2*omega*(-coskx*temp1+hx*sinkx*temp3)
ENDIF
IF(present(phi)) THEN
    phi  =  temp2*(-sinkx*temp1-hx*coskx*temp3)
ENDIF
END SUBROUTINE phi_linear_bottom


program intrinsics_04s
complex :: z

z = (1.5, 0.1)
z = tan(z)
print *, z
if (abs(real(z) - 4.69238520) > 1e-5) error stop
!if (abs(aimag(z) - 6.69462872) > 1e-5) error stop

end


module distance

  ! Healpix module
  use healpix_types

  implicit none

  contains

    real(kind=dp) function s2(phi1, phi2, theta1, theta2)

      real(kind=dp), intent(in) :: phi1, phi2, theta1, theta2

      s2 = dacos(dcos(theta1) * dcos(theta2) + dsin(theta1) * dsin(theta2) &
      * dcos(phi1 - phi2))

    end function s2

    real(kind=dp) function r2(x1, x2, y1, y2)

      real(kind=dp), intent(in) :: x1, x2, y1, y2

      r2 = dsqrt((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))

    end function r2

    subroutine cross(phi1a, theta1a, phi1b, &
      theta1b, phi2a, theta2a, phi2b, theta2b, phi, theta)

      real(kind=dp), intent(in) :: phi1a, theta1a, phi1b, &
      theta1b, phi2a, theta2a, phi2b, theta2b
      real(kind=dp), intent(out) :: phi, theta

      real(kind=dp), dimension(0:2) :: a1, b1, c1, a2, b2, c2, a
      real(kind=dp) :: mod

      a1 = (/dcos(theta1a) * dcos(phi1a), &
      dcos(theta1a) * dsin(phi1a), dsin(theta1a)/)
      b1 = (/dcos(theta1b) * dcos(phi1b), &
      dcos(theta1b) * dsin(phi1b), dsin(theta1b)/)
      c1 = (/a1(1) * b1(2) - a1(2) * b1(1), &
      a1(2) * b1(0) - a1(0) * b1(2), a1(0) * b1(1) - a1(1) * b1(0)/)

      a2 = (/dcos(theta2a) * dcos(phi2a), &
      dcos(theta2a) * dsin(phi2a), dsin(theta2a)/)
      b2 = (/dcos(theta2b) * dcos(phi2b), &
      dcos(theta2b) * dsin(phi2b), dsin(theta2b)/)
      c2 = (/a2(1) * b2(2) - a2(2) * b2(1), &
      a2(2) * b2(0) - a2(0) * b2(2), a2(0) * b2(1) - a2(1) * b2(0)/)

      a = (/c1(1) * c2(2) - c1(2) * c2(1), &
      c1(2) * c2(0) - c1(0) * c2(2), c1(0) * c2(1) - c1(1) * c2(0)/)
      mod = dsqrt(a(0) * a(0) + a(1) * a(1) + a(2) * a(2))

      phi = datan(a(1) / a(0))
      theta = dasin(a(2) / mod)

    end subroutine

end module distance


program main

    use euler_primes_m, only: sieve_of_Eratosthenes
    implicit none

    call title("'euler_primes_m'")
    generate_arr_of_primes: block
        integer :: i
        logical, allocatable :: is_prime(:)
        integer, allocatable :: prime(:)
        integer, parameter :: PRIME_UPPER_BOUND = 100
        integer, allocatable :: primes_under_100(:)
        logical :: cond

        primes_under_100 = [2, 3, 5, 7, 11, 13, 17, 19, 23, &
                            29, 31, 37, 41, 43, 47, 53, 59, &
                            61, 67, 71, 73, 79, 83, 89, 97]
        call sieve_of_Eratosthenes(PRIME_UPPER_BOUND, is_prime)
        prime = pack([(i, i=0, PRIME_UPPER_BOUND)], is_prime)
        cond = all(primes_under_100 == prime)
        call test(cond, "sieve_of_Eratosthenes")
    end block generate_arr_of_primes

contains

    subroutine test(input_condition, input_name)
        logical, intent(inout) :: input_condition
        character(*), intent(in) :: input_name

        if (input_condition) then
            print "(a)", "Testing "//input_name//"... passed."
        else
            print "(a)", "Testing "//input_name//"... not passed!"
            stop
        end if
    end subroutine test

    subroutine title(input_name)
        character(*), intent(in) :: input_name

        print "(a)", "Testing "//input_name//"..."
    end subroutine title

end program main


subroutine ff_cylinder(q,R,L,ff,M)
    !***************************************************************************
    !Subroutine to calculate the form factor of cylinder
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Radius of cylinder in Angstroms
    !L = Length of cylinder in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, i, j
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double precision :: R, L, alpha, fact
    double precision, parameter :: pi=3.14157
    integer, parameter :: N=1000

    do i = 0,M
        do j=1,N
            alpha=pi*j/N/2.0
            fact=(sin(q(i)*L*cos(alpha)/2)/(q(i)*L*cos(alpha)/2) * bessel_j1(q(i)*R*sin(alpha))/(q(i)*R*sin(alpha)))**2
            ff(i) = ff(i) + fact * sin(alpha)
        enddo
        ff(i) = ff(i)*pi/N
    enddo

end subroutine ff_cylinder

subroutine ff_cylinder_dist(q,R,Rdist,L,Ldist,ff,M,N)
    !***************************************************************************
    !Subroutine to calculate the form factor of cylinder with disctribution of radius and length
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !R = Array of radii of cylinder in Angstroms
    !Rdist = Probablity distribution of radii R
    !L = Array of Length of cylinder in Angstroms
    !Ldist = Probablity distribution of length L
    !N = No. of samples R and L
    !ff = Form factor of cylinder
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !***************************************************************************
    integer :: M, N, i, j
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double precision :: R(0:N), Rdist(0:N), L(0:N), Ldist(0:N), fact1, fact2, tsum
    double precision, parameter :: pi=3.14157
    integer, parameter :: Nangles=1000
    double precision :: alpha(0:Nangles)

    do j=1,Nangles
        alpha(j)=pi*j/Nangles/2.0
    end do

    do i = 0,M
        ff(i)=0.0d0
        do k=0,N
            tsum=0.0d0
            do j=1,Nangles
                fact1=sin(q(i)*L(k)*cos(alpha(j))/2.0d0)/(q(i)*L(k)*cos(alpha(j))/2.0d0)
                fact2=bessel_j1(q(i)*R(k)*sin(alpha(j)))/(q(i)*R(k)*sin(alpha(j)))
                tsum = tsum + fact1**2*fact2**2*sin(alpha(j))
            enddo
            ff(i) = ff(i)+tsum*Rdist(k)*Ldist(k)
        end do
        ff(i) = ff(i)*pi/sum(Rdist)/sum(Ldist)/Nangles
    enddo

end subroutine ff_cylinder_dist

subroutine ff_cylinder_ML(q,rho,R,L,ff,ffamp,M, Nl)
    !***************************************************************************
    !Subroutine to calculate the form factor of Multilayered Cylinder
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !rho= List of complex electron density of different layers including the solvent
    !R = List of Radius and shell thicknesses of multilayered cylinder in Angstroms
    !L = Length of cylinder in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !Nl = No. of multilayers
    !***************************************************************************
    integer :: M, Nl, i, j, K
    double precision :: q(0:M)
    double precision :: ff(0:M)
    double complex :: rho(0:Nl)
    double precision :: R(0:Nl)
    double precision :: L, alpha, rtemp
    double complex :: fact
    double complex :: ffamp(0:M)
    double precision, parameter :: pi=3.14157
    integer, parameter :: N=1000

    do i = 0,M
        do j=1,N
            alpha=pi*j/N/2.0
            fact=dcmplx(0.0,0.0)
            rtemp=0
            do k=0,Nl-1
                rtemp=rtemp+R(k)
                fact=fact+(rho(k+1)-rho(k))*(dsin(q(i)*L*dcos(alpha)/2)/(q(i)*L*dcos(alpha)/2) &
                * bessel_j1(q(i)*rtemp*dsin(alpha))/(q(i)*rtemp*dsin(alpha)))
            enddo
            ff(i) = ff(i) + cdabs(fact)**2 * dsin(alpha)
            ffamp(i) = ffamp(i) + fact * dsin(alpha)
        enddo
        ff(i) = ff(i)*pi/N
        ffamp(i) = ffamp(i)*pi/N
    enddo

end subroutine ff_cylinder_ML


module SphereTransportVelocitiesModule

use NumberKindsModule
use SphereGeomModule

implicit none

public

contains

function MovingVorticesVelocity( x, y, z, t )
	real(kreal), dimension(3) :: MovingVorticesVelocity
	real(kreal), intent(in) :: x, y, z, t
	real(kreal), parameter :: u0 = 2.0_kreal * PI / 12.0_kreal
	real(kreal) :: lat, lon, rho, rhoDenom, omg, u, v

	lat = Latitude(x, y, z)
	lon = Longitude(x,y,z)

	rho = 3.0_kreal * sqrt(1.0_kreal - cos(lat) * cos(lat) * sin( lon - u0 * t) * sin(lon - u0*t ))
	rhoDenom = rho / ( rho * rho + ZERO_TOL * ZERO_TOL)
	omg = 1.5_kreal * sqrt(3.0_kreal) * u0 * tanh(rho) * rhoDenom / cosh(rho) / cosh(rho)

	u = omg * sin( lon - u0 * t) * sin(lat) + u0 * cos(lat)
	v = omg * cos( lon - u0 * t)

	MovingVorticesVelocity(1) = -u * sin(lon) - v * sin(lat) * cos(lon)
	MovingVorticesVelocity(2) =  u * cos(lon) - v * sin(lat) * sin(lon)
	MovingVorticesVelocity(3) =  v * cos(lat)
end function

function LauritzenEtalDeformationalVelocity( x, y, z, t )
	real(kreal), dimension(3) :: LauritzenEtalDeformationalVelocity
	real(kreal), intent(in) :: x, y, z, t
	real(kreal), parameter :: RR = 1.0_kreal
	real(kreal), parameter :: TT = 5.0_kreal
	real(kreal) :: u, v, lat, lon

	lat = Latitude(x, y, z)
	lon = Longitude(x, y, z)
	u = 10.0_kreal * RR / TT * sin(lon - 2.0_kreal * PI * t / TT) * sin(lon - 2.0_kreal * PI * t / TT ) * &
		sin(2.0_kreal * lat ) * cos( PI * t / TT) + 2.0_kreal * PI * RR / TT * cos(lat)
	v = 10.0_kreal * RR / TT * sin(2.0_kreal * (lon - 2.0_kreal * PI * t / TT)) * cos(lat) * cos(PI * t/TT )

	LauritzenEtalDeformationalVelocity(1) = -u * sin(lon) - v * sin(lat) * cos(lon)
	LauritzenEtalDeformationalVelocity(2) =  u * cos(lon) - v * sin(lat) * sin(lon)
	LauritzenEtalDeformationalVelocity(3) =  v * cos(lat)
end function

function LauritzenEtalDivergentFlowVelocity( x, y, z, t )
	real(kreal), dimension(3) :: LauritzenEtalDivergentFlowVelocity
	real(kreal), intent(in) :: x, y, z, t
	real(kreal), parameter :: RR = 1.0_kreal
	real(kreal), parameter :: TT = 5.0_kreal
	real(kreal), parameter :: relPeriod = RR / TT
	real(kreal) :: u, v, lat, lon, lamPrime

	lat = Latitude(x, y, z)
	lon = Longitude(x, y, z)
	lamPrime = lon - 2.0_kreal * PI * t / TT

	u = - 5.0_kreal * relPeriod * sin( 0.5_kreal * lamPrime) * sin( 0.5_kreal * lamPrime ) * sin( 2.0_kreal * lat ) * &
		cos(lat) * cos(lat) * cos( PI * t / TT ) + 2.0_kreal * PI * relPeriod * cos(lat)
	v = 2.5_kreal * relPeriod * sin(lamPrime) * cos(lat) * cos(lat) * cos(lat) * cos( PI * t / TT )

	LauritzenEtalDivergentFlowVelocity(1) = -u * sin(lon) - v * sin(lat) * cos(lon)
	LauritzenEtalDivergentFlowVelocity(2) =  u * cos(lon) - v * sin(lat) * sin(lon)
	LauritzenEtalDivergentFlowVelocity(3) =  v * cos(lat)
end function

function LauritzenEtalDivergentFlowDivergence( x, y, z, t )
	real(kreal) :: LauritzenEtalDivergentFlowDivergence
	real(kreal), intent(in) :: x, y, z, t
	real(kreal), parameter :: TT = 5.0_kreal
	real(kreal) :: u, v, lat, lon, lamPrime

	lat = Latitude(x, y, z)
	lon = Longitude(x, y, z)
	lamPrime = lon - 2.0_kreal * PI * t / TT

	LauritzenEtalDivergentFlowDivergence = - 15.0_kreal * cos(lat) * cos(lat) * cos( PI * t / TT ) * sin(lat) * &
		sin(lamPrime) / TT
end function

function RH4Velocity( x, y, z, t )
	real(kreal), dimension(3) :: RH4Velocity
	real(kreal), intent(in) :: x, y, z, t
	real(kreal) :: u, v, lat, lon
!	real(kreal), parameter :: u0 = 0.0_kreal
!	real(kreal), parameter :: amp = 1.0_kreal
	real(kreal), parameter :: bkgrdRotVel = 5.0_kreal / 12.0_kreal / 2.0_kreal * PI

	lat = Latitude(x, y, z)
	lon = Longitude(x, y, z)

!	u = cos(lat) * ( u0 - 0.5_kreal * amp * cos( 4.0_kreal * lon ) * cos(lat) * cos(lat) * &
!		(-3.0_kreal + 5.0_kreal * cos(2.0_kreal * lat )) )
!	v = -4.0_kreal * amp * cos(lat) * cos(lat) * cos(lat) * sin(4.0_kreal * lon ) * sin(lat)

	u = 0.5_kreal * cos( 4 * lon) * cos(lat) ** 3 * ( 5.0_kreal * cos(2.0_kreal * lat) - 3.0_kreal )
	v = 4.0_kreal * cos( lat ) ** 3 * sin(lat) * sin( 4.0_kreal * lon)

	RH4Velocity(1) =  - bkgrdRotVel * y - u * sin(lon) - v * sin(lat) * cos(lon)
	RH4Velocity(2) =  bkgrdRotVel * x + u * cos(lon) - v * sin(lat) * sin(lon)
	RH4Velocity(3) =  v * cos(lat)
end function

end module


  function gauss2 (evapObj, xmean, sd)

! ======================================================================
!
!   This routine finds a random deviate with a gaussian distribution
!   of mean xmean and standard deviation sd.
!
!   This is a modified version of GASDEV, from Numerical Recipes, 2nd
!   Ed. by Press et al., Oxford (1992).  This version uses the function
!///RNDM as defined by Mokhov, instead of RAN1 from Numer. Recipes.////
!   RANG as used in MCNP6.
!
!   GAUSS2 uses an average of 4/pi = 1.273... random numbers for each
!   gaussian-distributed random number, as opposed to 12 for GAUSSN!!
!
!   Written by A. J. Sierk, LANL T-16, September, 2003.
!   Modified by A. J. S. December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one, two

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    real(real64), intent(in   ) :: xmean   ! Mean value         of Gaussian
    real(real64), intent(in   ) :: sd      ! Standard Deviation of Gaussian
    real(real64)                :: gauss2  ! Random deviate of the Gaussian

    real(real64)   :: fac, gasdev, rsq, v1, v2

! ======================================================================

    integer(int32), save :: iset = 0_int32   ! Flags first or second call to the function
    real(real64),   save :: gset = zro       ! Contains random deviate for the second call to the function

! ======================================================================

    if (iset == 0) then
       ! Obtain valid 'rsq' value [in range (0, 1) ]
10     continue
       v1 = two*evapObj%rang() - one
       v2 = two*evapObj%rang() - one
       rsq = v1**2 + v2**2
       if (rsq >= one .or. rsq == zro) go to 10

       ! Obtain random deviate
       fac = sqrt(-two*log(rsq)/rsq)
       gset = v1*fac     ! Random deviate for second call
       gasdev = v2*fac   ! Random deviate for first call
       iset = 1          ! Flag to use "second" call
    else
       gasdev = gset   ! Set random deviate from previous call
       iset = 0        ! Reset to "first" call
    endif

    ! Obtain Value of gauss2 given the random deviate, mean, and standard deviation
    gauss2 = sd*gasdev + xmean

    return
! ======================================================================
  end function gauss2


c     program DRCGE2
c>> 1992-03-11 DRCGE2 Lawson
c     Demo driver for CGEFS, CGEFA, CGESLT, CGED, CGEI.
c     Solution of square nonsingular system of linear equations
c     having complex elements.
c     ------------------------------------------------------------------
      integer I, INFO, J, NMAX
      parameter (NMAX=3)
      complex   A(3,3), AH(3,3), B(3,1), C(3,1), DET(2), WORK(3)
      integer   IPVT(NMAX)
      data (A(1,J),J=1,3) / (0.579e0,0.735e0), (0.394e0,0.537e0),
     *                      (0.915e0,0.143e0) /
      data (A(2,J),J=1,3) / (0.795e0,0.430e0), (0.226e0,0.384e0),
     *                      (0.868e0,0.494e0) /
      data (A(3,J),J=1,3) / (0.141e0,0.207e0), (0.329e0,0.635e0),
     *                      (0.286e0,0.971e0) /
      data (B(I,1),I=1,3) / (-2.405e0,-4.735e0), (3.87e0,-3.08e0),
     *                      (4.231e0,-0.213e0) /
      data (C(I,1),I=1,3) / (-2.405e0,-4.735e0), (3.87e0,-3.08e0),
     *                      (4.231e0,-0.213e0) /
c     ------------------------------------------------------------------
      print'(a)',
     * ' DRCGE2..  Demo driver for CGEFS, CGEFA, CGESLT, CGED, CGEI.'
c
c                            Store Hermitian transpose of A() into AH()
c
      do 30 I = 1,3
         do 20 J = 1,3
            AH(I,J) = conjg(A(J,I))
   20    continue
   30 continue
c
      call CGEFS(A,NMAX,NMAX,B,NMAX,1,IPVT,INFO)
      print'(a)',' ',
     * ' True solution of A*x = b is (2,4), (-5,5), (3,-9)',
     * ' Computed solution:'
      do 10 I = 1,3
        print '(1x,a,i1,a,f10.6,'','',f10.6,a)',
     *        'X(', I,') = (', B(I,1),')'
  10  continue
c
      call CGEFA( AH, NMAX, NMAX, IPVT, INFO)
      call CGESLT(AH, NMAX, NMAX, IPVT, C)
      print'(a)',' ', ' Set D = A**h and solve (D**h)*x = b.',
     * ' Expect same solution.', ' Computed solution:'
      do 40 I = 1,3
        print '(1x,a,i1,a,f10.6,'','',f10.6,a)',
     *        'X(', I,') = (', C(I,1),')'
  40  continue
c
      call CGED(A, NMAX, NMAX, IPVT, DET)
      print'(/a/a,f10.6,'','',f10.6,a/a,f10.6,'','',f10.6,a)',
     *   ' Determinant of A is DET(1) * 10**DET(2) where',
     *   '    DET(1) = (',DET(1),') and',
     *   '    DET(2) = (',DET(2),')'
c
      call CGEI(A, NMAX, NMAX, IPVT, WORK)
      print'(/a/
     *   ('' ('',f10.6,'','',f10.6,'')  ('',
     *           f10.6,'','',f10.6,'')  ('',
     *           f10.6,'','',f10.6,'')''))',
     *  ' Inverse of A:', ((A(I,J),J = 1,3),I=1,3)
      end


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes Gauss-Legendre-Lobatto nodes, weigths and spectral derivatives.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nb_pnt  polynomial  degree
!> @param[out] xq  LGL nodes
!> @param[out] wq  LGL weights
!> @param[out] dd  matrix for  spectral derivatives

     subroutine MAKE_LGL_NW(nb_pnt, xq, wq, dd)

     implicit real*8 (a-h,o-z)

      parameter (nstep = 1000, acc = 1.d-15)

      integer*4, intent(inout) :: nb_pnt
      real*8, dimension(nb_pnt) :: xq, wq
      real*8, dimension(nb_pnt) :: dd(nb_pnt,nb_pnt)

      n = nb_pnt-1
      xq(1) = -1.d0
      xq(nb_pnt) = 1.d0
      n2=idint(0.5d0*nb_pnt)
      dx=2.d0/dfloat(nstep)

      x = -1.d0
      iroot = 1

      call GET_LEGENDRE_VALUE(p2,a1,p1,p1der,n,x)

      do while (iroot .lt. n2)
        x = x + dx
        call GET_LEGENDRE_VALUE(p2,a2,p1,p1der,n,x)

        if (dabs(a2) .le. acc) then
          iroot = iroot + 1
          xq(iroot) = a2
        else
          aa = a1 * a2
          if (aa .lt. 0.d0) then
            iroot = iroot + 1
            xq(iroot) = FIND_ROOT_POL(x-dx,x,acc,n)
          endif
        endif

        a1 = a2
      enddo

      n_filt = 2*n2
      if (n_filt .ne. nb_pnt) then         ! nb_pnt odd
        xq(n2+1) = 0.d0
        do i = 1, n2-1
          xq(nb_pnt-i) = -xq(i+1)
        enddo
      else                           ! nb_pnt even
        do i = 1, n2-1
          xq(nb_pnt-i) = -xq(i+1)
        enddo
      endif

      xn = dfloat(n)
      acost = 2.d0/(xn*(xn+1.d0))

      do j = 1,nb_pnt
         call GET_LEGENDRE_VALUE(p2,p2der,p1,p1der,n,xq(j))
         den = p2*p2
         wq(j) = acost/den

         do i = 1, nb_pnt
            if (i .ne. j) then
               call GET_LEGENDRE_VALUE(pnum,p2der,p1,p1der,n,xq(i))
               den = p2 * (xq(i)-xq(j))
               dd(i,j) = pnum / den
            endif
         enddo

      enddo

      do j = 2, nb_pnt-1
         dd(j,j) = 0.d0
      enddo

      dd(1,1) = -0.25d0 * xn * (xn+1.d0)
      dd(nb_pnt,nb_pnt) = 0.25d0 * xn * (xn+1.d0)

      return

      end subroutine MAKE_LGL_NW


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.

    ! Specify two right-going shocks with R-H condition satisfied across each

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    real(kind=8) :: h1,u1,hu1,h2,u2,hu2,h3,u3,hu3,s12,s23,xedge
    integer :: i

    real(kind=8) :: grav
    common /cparam/ grav

    ! # data in middle state:
    h2 = 2.d0
    u2 = 0.d0
    hu2 = h2*u2

    ! # data in left state:
    h1 = 4.d0
    u1 = sqrt(0.5d0*grav*(h2/h1 - h1/h2) * (h2-h1))
    hu1 = h1*u1

    ! # data in right state:
    h3 = 0.8d0
    u3 = -sqrt(0.5d0*grav*(h2/h3 - h3/h2) * (h2-h3))
    hu3 = h3*u3

    s12 = (hu2-hu1) / (h2-h1)
    s23 = (hu2-hu3) / (h2-h3)
    write(6,*) 'shock speeds:', s12, s23

    do i=1,mx
        xedge = xlower + (i-1)*dx
        if (xedge .lt. -4.0d0) then
            q(1,i) = h1
            q(2,i) = hu1
          else if (xedge .lt. -2.5d0) then
            q(1,i) = h2
            q(2,i) = hu2
          else
            q(1,i) = h3
            q(2,i) = hu3
          endif
        enddo

end subroutine qinit


PROGRAM mcpsi

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!     =========================================================
!     Purpose: This program computes the psi function psi(z)
!     for a complex argument using subroutine CPSI
!     Input :  x   --- Real part of z
!     y   --- Imaginary part of z
!     Output:  PSR --- Real part of psi(z)
!     PSI --- Imaginary part of psi(z)
!     Examples:
!     x       y      Re[psi(z)]     Im[psi(z)]
!     -------------------------------------------
!     3.0     2.0     1.16459152      .67080728
!     3.0    -2.0     1.16459152     -.67080728
!     -3.0     2.0     1.39536075     2.62465344
!     -3.0    -2.0     1.39536075    -2.62465344
!     =========================================================

DOUBLE PRECISION :: x,y,psr,psi
WRITE(*,*)'Please enter x and y ( z=x+iy)'
!     READ(*,*)X,Y
x=3.0
y=2.0
WRITE(*,20)x,y
WRITE(*,*)
WRITE(*,*)'   x       y      Re[Psi(z)]      Im[Psi(z)]'
WRITE(*,*)' ----------------------------------------------'
CALL cpsi(x,y,psr,psi)
WRITE(*,10)x,y,psr,psi
10   FORMAT(1X,f5.1,3X,f5.1,2X,2E16.8)
20   FORMAT(1X,2HX=,f6.2,6X,2HY=,f6.2)
END PROGRAM mcpsi

SUBROUTINE cpsi(x,y,psr,psi)

!     =============================================
!     Purpose: Compute the psi function for a
!     complex argument
!     Input :  x   --- Real part of z
!     y   --- Imaginary part of z
!     Output:  PSR --- Real part of psi(z)
!     PSI --- Imaginary part of psi(z)
!     =============================================

DOUBLE PRECISION, INTENT(IN OUT)         :: x
DOUBLE PRECISION, INTENT(IN OUT)         :: y
DOUBLE PRECISION, INTENT(OUT)            :: psr
DOUBLE PRECISION, INTENT(OUT)            :: psi
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION a(8)
DATA a/-.8333333333333D-01,.83333333333333333D-02,  &
    -.39682539682539683D-02,.41666666666666667D-02,  &
    -.75757575757575758D-02,.21092796092796093D-01,  &
    -.83333333333333333D-01,.4432598039215686D0/

x1=0.0
pi=3.141592653589793D0
IF (y == 0.0D0.AND.x == INT(x).AND.x <= 0.0D0) THEN
  psr=1.0D+300
  psi=0.0D0
ELSE
  IF (x < 0.0D0) THEN
    x1=x
    y1=y
    x=-x
    y=-y
  END IF
  x0=x
  IF (x < 8.0D0) THEN
    n=INT(8-INT(x))
    x0=x+n
  END IF
  IF (x0 == 0.0D0.AND.y /= 0.0D0) th=0.5D0*pi
  IF (x0 /= 0.0D0) th=DATAN(y/x0)
  z2=x0*x0+y*y
  z0=DSQRT(z2)
  psr=DLOG(z0)-0.5D0*x0/z2
  psi=th+0.5D0*y/z2
  DO  k=1,8
    psr=psr+a(k)*z2**(-k)*DCOS(2.0D0*k*th)
    psi=psi-a(k)*z2**(-k)*DSIN(2.0D0*k*th)
  END DO
  IF (x < 8.0D0) THEN
    rr=0.0D0
    ri=0.0D0
    DO  k=1,n
      rr=rr+(x0-k)/((x0-k)**2.0D0+y*y)
      ri=ri+y/((x0-k)**2.0D0+y*y)
    END DO
    psr=psr-rr
    psi=psi+ri
  END IF
  IF (x1 < 0.0D0) THEN
    tn=DTAN(pi*x)
    tm=DTANH(pi*y)
    ct2=tn*tn+tm*tm
    psr=psr+x/(x*x+y*y)+pi*(tn-tn*tm*tm)/ct2
    psi=psi-y/(x*x+y*y)-pi*tm*(1.0D0+tn*tn)/ct2
    x=x1
    y=y1
  END IF
END IF
RETURN
END SUBROUTINE cpsi


! This program shows how to use selected_real_kind
! SELECTED_REAL_KIND(P,R) returns the kind value of
! a real data type with decimal precision of at least
! P digits, exponent range of at least R, and with
! a radix of RADIX.
!
! Note the repeated kind type values for different precisions.
! Not all real representations are available
!
program kind_real_range
  implicit none
  integer, parameter  :: p1   = selected_real_kind(r=1)
  integer, parameter  :: p2   = selected_real_kind(r=2)
  integer, parameter  :: p3   = selected_real_kind(r=3)
  integer, parameter  :: p4   = selected_real_kind(r=4)
  integer, parameter  :: p5   = selected_real_kind(r=5)
  integer, parameter  :: p6   = selected_real_kind(r=6)
  integer, parameter  :: p7   = selected_real_kind(r=7)
  integer, parameter  :: p8   = selected_real_kind(r=8)
  integer, parameter  :: p9   = selected_real_kind(r=9)
  integer, parameter  :: p10  = selected_real_kind(r=10)

  real(kind = p1)     :: v1
  real(kind = p2)     :: v2
  real(kind = p3)     :: v3
  real(kind = p4)     :: v4
  real(kind = p5)     :: v5
  real(kind = p6)     :: v6
  real(kind = p7)     :: v7
  real(kind = p8)     :: v8
  real(kind = p9)     :: v9
  real(kind = p10)    :: v10

  print*,'selected_real_kind(r=1)', p1
  print*,' p = ', precision(v1), ' r = ', &
         range(v1), ' radix = ', radix(v1)
  print*,'selected_real_kind(r=2)', p2
  print*,' p = ', precision(v2), ' r = ', &
         range(v2), ' radix = ', radix(v2)
  print*,'selected_real_kind(r=3)', p3
  print*,' p = ', precision(v3), ' r = ', &
         range(v3), ' radix = ', radix(v3)
  print*,'selected_real_kind(r=4)', p4
  print*,' p = ', precision(v4), ' r = ', &
         range(v4), ' radix = ', radix(v4)
  print*,'selected_real_kind(r=5)', p5
  print*,' p = ', precision(v5), ' r = ', &
         range(v5), ' radix = ', radix(v5)
  print*,'selected_real_kind(r=6)', p6
  print*,' p = ', precision(v6), ' r = ', &
         range(v6), ' radix = ', radix(v6)
  print*,'selected_real_kind(r=7)', p7
  print*,' p = ', precision(v7), ' r = ', &
         range(v7), ' radix = ', radix(v7)
  print*,'selected_real_kind(r=8)', p8
  print*,' p = ', precision(v8), ' r = ', &
         range(v8), ' radix = ', radix(v8)
  print*,'selected_real_kind(r=9)', p9
  print*,' p = ', precision(v9), ' r = ', &
         range(v9), ' radix = ', radix(v9)
  print*,'selected_real_kind(r=10)', p10
  print*,' p = ', precision(v10), ' r = ', &
         range(v10), ' radix = ', radix(v10)
end program kind_real_range


subroutine astro(doy, lat, dayl, daylp, sinld, cosld, dsinb, dsinbe, &
                    sc, dso)
! ----------------------------------------------------------------------
! Subroutine astro (daynr,lat,dayl,daylp,sinld,cosld)
! Authors: this routine Astro is based on Sastro (Daniel van Kraalingen)
! Implemented with permission by Murilo Vianna.
! Date   : 28-November-2005
! Purpose: This subroutine calculates solar constant, daily
!          extraterrestrial radiation, daylength and some intermediate
!          variables required by other routines. The routine has been
!          rewritten such that latitudes from pole to pole can be used.
!
! Formal parameters:  (I=input,O=output,C=control,IN=init,T=time)
! name   type meaning                                     units  class
! ----   ---- -------                                     -----  -----
! daynr   I4  Day of year (Jan 1st = 1)                      d      I
! lat     R8  Latitude of the site                       degrees    I
! dayl    R8  Astronomical daylength (base = 0 degrees)      h      O
! daylp   R8  Photoperiodic daylength (base = -4 degrees)    h      O
! sinld   R8  Intermediate variable for other subroutine     -      O
! cosld   R8  Intermediate variable for other subroutine     -      O
! dsinb   R8  Daily total of sine of solar height            s      O
! dsinbe  R8  Daily integral of sine of solar height         s      O
!             corrected for lower transmission at low
!             elevation
! sc      R8  Solar constant at day=daynr                   W/m2     O
! dso     R8  Daily extraterrestrial radiation            J/m2/d    O
!
! Fatal error checks (on input): lat > 90, lat < -90
! Warnings          : lat above polar circle, lat within polar circle
! Subprograms called: Warning
! File usage        : none
!----------------------------------------------------------------------
      !use VarDefs
      implicit none

!     formal parameters(I=input,O=output,C=control,IN=init,T=time)

!     local parameters
      real  angle,aob,dec,rad,zza,zzcos,zzsin,sc,help1
      character messag*200

      !--- DSSAT Coupling
      real      sinld
      real      cosld
      real      lat
      real      dayl
      real      daylp
      real      dsinb
      real      dsinbe
      real      dso
      integer   doy
      real ::   pi = 3.14159265

      data    angle /-4.0d0/
! ----------------------------------------------------------------------
! --- declination of the sun as a function of daynr
!     (see ref.manual: Radiation term: 23.45*rad=0.409 en (90-10)*rad=1.39)
      rad = pi/180.d0
      dec = -asin(sin(23.45d0*rad)*cos(2.d0*pi*dble(doy+10)/365.0d0))
! --- some intermediate variables
      sinld = sin(rad*lat)*sin(dec)
      cosld = cos(rad*lat)*cos(dec)
      aob = sinld/cosld
      !aob = (tan(lat)*tan(dec))
! --- calculation of daylenght and photoperiodic daylength
!     solution for polar circle altutude adopted from
!     Daniel van Kraalingen (routine Sastro, dd 12-june-1996,version 1.1)
      if (aob.lt.-1.0d0) then
        !msg = 'Warning: latitude above polar circle, daylength= 0hrs'

        dayl = 0.0d0
        zzcos =  0.0d0
        zzsin =  1.0d0
      else if (aob.gt.1.0d0) then
        !messag = 'Warning: latitude within polar circle,daylength=24hrs'

        dayl = 24.0d0
        zzcos =  0.0d0
        zzsin = -1.0d0
      else
        dayl  = 12.0d0*(1.0d0+2.0d0*asin(aob)/pi)
        help1 = (-sin(angle*rad)+sinld)/cosld
        if (help1.gt.1.0d0) then
          daylp = 24.0d0
        else
          daylp = 12.0d0*(1.0d0+2.0d0*asin(help1)/pi)
        endif
!
        zza   = pi*(12.0d0+dayl)/24.0d0
        zzcos = cos (zza)
        zzsin = sin (zza)
      endif

!     Daily integral of sine of solar height (DSINB) with a
!     correction for lower atmospheric transmission at lower solar
!     elevations (DSINBE)
      dsinb  = 2.0d0*3600.0d0*(dayl*0.50d0*sinld-12.0d0*cosld*zzcos/pi)
      dsinbe = 2.0d0*3600.0d0*(dayl*(0.50d0*sinld+0.20d0*sinld**2.0d0+0.10d0*cosld**2.0d0)-(12.0d0*cosld*zzcos+9.6d0*sinld*cosld*zzcos+2.4d0*cosld**2.0d0*zzcos*zzsin)/pi)

!     Solar constant and daily extraterrestrial radiation
      sc = 1370.0d0*(1.0d0+0.033d0*cos (2.0d0*pi*doy/365.d0))
      dso  = sc*dsinb

      return
      end subroutine astro


module module_gauss_legendre_quadrature
  implicit none

  private
  public assemble_gauss

contains
  !> ガウス積分の分点と重み
  !! \param ng 分点の数
  !! \param gz 分点の座標
  !! \param we 重み
  subroutine assemble_gauss(n,gz,we)
    integer,intent(in) :: n
    real(8),intent(out) :: gz(n), we(n)

    !> 対称三重対角行列の対角成分
    real(8) :: td(n)

    !> 対称三重対角行列の非対角成分
    real(8) :: tl(n-1)

    !> 固有ベクトル
    complex(8) :: q(n,n)

    integer :: i, info
    real(8) :: work(2*n-2)

    td(:)=0.d0
    do i=1,n-1
       tl(i)=dble(i)/sqrt((2.d0*i-1.0d0)*(2.0*i+1.d0))
    end do

    q(:,:)=cmplx(0.d0,0.d0,kind(1.d0))
    do i=1,n
       q(i,i)=cmplx(1.d0,0.d0,kind(1.d0))
    end do

    call zsteqr("V",n,td,tl,q,n,work,info)

    do i=1,n
       gz(i)=td(i)
       we(i)=2.d0*(real(q(1,i))**2+aimag(q(1,i))**2)
    end do

  end subroutine assemble_gauss

end module module_gauss_legendre_quadrature


! 4670 Numerical Analysis
! Homework Two Redo

! From Notes on Bisection Method:
! f needs to be continuous
! 1. Start with a, b so that f(a), f(b) have opposite signs
! 2. Find the middle M = (a+b)/2 and calculate f(M)
! 3. If f(a) and f(M) have opposite signs
! set b = M
! else set a = M
! end if
! Loop back to #2

module secret

end module secret

program WebberHomework2Question1
use secret							! uses secret module
implicit none

real :: a
real :: b
real :: f
real :: m
real :: mid
real :: tolerance

integer :: i
integer :: findSign 						! I didn't realize "sign" was a
								! reserved word
a = -10.0d0
b = 10.0d0
tolerance = 1.0d0-10

do i = 1, 10
	m = mid(a, b)						! find the middle and calculate f(M)

	if (m < tolerance) then 				! if m is less than tolerance then
		print*, "Middle = ", m				! prints the middle
		stop
	else if (f(m) == 0) then				! else if f(m) equals zero then
		print*, "Middle = ", m				! prints the middle
		stop
	else 							! if neither case is true
		print*, "f(a, b) = (", a, ",", b, ") and m = ", m
	end if

	if ((findSign(f(a)) * findSign(f(m))) < 0) then		! if f(a) && f(M) have opposite signs
		b = m						! it sets b to M
	else
		a = b						! else it sets a to b
	end if
end do

stop
end program WebberHomework2Question1

real function f(x)						! main function for the problem
implicit none

real :: x

f = ((x**3)-30)							! equation for f = x^3 - 30

return
end

real function mid(a,b)						! function to find midpoint
implicit none

real :: a
real :: b

mid = ((a + (b - a)) / 2)					! midpoint formula

return
end

integer function findSign(x)					! function to determine if negative
implicit none							! or positive

real :: x

if (x < 0) then 						! if less than zero sign is -1
	findSign = -1
else if (x == 0) then						! else if x is zero sign is 0
	findSign = 0
else								! if x is greater than zero sign is 1
	findSign = 1
end if

return
end


subroutine fine_to_coarse(r_h, nx, ny, xi_h, xf_h, xi_2h, xf_2h, r_2h)
use parallel_variables
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi_h, xf_h, xi_2h, xf_2h
real(kind=dp), intent(in), dimension(nx,xi_h-1:xf_h+1):: r_h
real(kind=dp), intent(out), dimension(nx/2+1,xi_2h-1:xf_2h+1):: r_2h
real(kind=dp):: w1, w2, w3, w4
integer:: imax, jmax
integer:: i, j

! Apply full weighting to get interpolated values from fine to coarse grid
! Input
! r_h   Variable in fine grid
! f     Right Hand Side
! hx, hy     grid spacing
!
! Output
! r_2h     Variable in coarse grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Indices Rechecked on Jan 13, 2013

if (mod(nx,2) .eq. 0) then

	imax = nx/2+1

else

	imax = (nx+1)/2

end if

if (mod(ny,2) .eq. 0) then

	jmax = ny/2+1

else

	jmax = (ny+1)/2

end if

if (1 .eq. 1) then

do j = xi_2h,xf_2h

    do i = 2,imax-1

        r_2h(i,j) = 1.0d0/4.0d0*(r_h(2*i-2,2*j-2) + r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-2) + r_h(2*i-1,2*j-1))

     end do

end do

end if

if (1 .eq. 0) then

do j = xi_2h,xf_2h

    do i = 2,imax-1

        r_2h(i,j) = 1.0d0/4.0d0*3.0d0*(r_h(2*i-2,2*j-2) + r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-2) + r_h(2*i-1,2*j-1)) + 1.0d0/4.0d0*(r_2h(i-1,j) + r_2h(i+1,j) + r_2h(i,j-1) + r_2h(i,j+1))

     end do

end do

end if

if (xi_2h .eq. 2) then

w1 = 0.0d0
w2 = 2.0d0
w3 = 0.0d0
w4 = 2.0d0

do j = 1,1

 do i = 2,imax-1

    r_2h(i,j) = 1.0d0/4.0d0*(w2*r_h(2*i-2,2*j-1) + w4*r_h(2*i-1,2*j-1))

 end do

end do

else if (xf_2h .eq. jmax-1) then

w1 = 2.0d0
w2 = 0.0d0
w3 = 2.0d0
w4 = 0.0d0

do j = jmax,jmax

 do i = 2,imax-1

    r_2h(i,j) = 1.0d0/4.0d0*(w1*r_h(2*i-2,2*j-2) + w3*r_h(2*i-1,2*j-2))

 end do

end do

end if

w1 = 0.0d0
w2 = 0.0d0
w3 = 2.0d0
w4 = 2.0d0

do j = xi_2h,xf_2h

 do i = 1,1

    r_2h(i,j) = 1.0d0/4.0d0*(w3*r_h(2*i-1,2*j-2) + w4*r_h(2*i-1,2*j-1))

 end do

end do

w1 = 2.0d0
w2 = 2.0d0
w3 = 0.0d0
w4 = 0.0d0

do j = xi_2h,xf_2h

 do i = imax,imax

    r_2h(i,j) = 1.0d0/4.0d0*(w1*r_h(2*i-2,2*j-2) + w2*r_h(2*i-2,2*j-1))

 end do

end do

call exchange_data(r_2h, imax, xi_2h, xf_2h)

end subroutine


program main

!*****************************************************************************80
!
!! MAIN is the main program for JACOBI_OPENMP.
!
!  Discussion:
!
!    JACOBI_OPENMP carries out a Jacobi iteration with OpenMP.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    31 January 2017
!
!  Author:
!
!    John Burkardt
!
  implicit none

  integer ( kind = 4 ), parameter :: n = 50000

  real ( kind = 8 ) b(n)
  real ( kind = 8 ) d
  integer ( kind = 4 ) i
  integer ( kind = 4 ) it
  integer ( kind = 4 ) m
  real ( kind = 8 ) r
  real ( kind = 8 ) t
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xnew(n)

  m = 5000

  write ( *, '(a)' ) ''
  write ( *, '(a)' ) 'JACOBI_OPENMP:'
  write ( *, '(a)' ) '  Fortran90/OpenMP version'
  write ( *, '(a)' ) '  Jacobi iteration to solve A*x=b.'
  write ( *, '(a)' ) ''
  write ( *, '(a,i8)' ) '  Number of variables  N = ', n
  write ( *, '(a,i8)' ) '  Number of iterations M = ', m

  write ( *, '(a)' ) ''
  write ( *, '(a)' ) '  IT     l2(dX)    l2(resid)'
  write ( *, '(a)' ) ''

!$omp parallel private ( i )
!
!  Set up the right hand side.
!
!$omp do
  do i = 1, n
    b(i) = 0.0D+00
  end do
!$omp end do
  b(n) = real ( n + 1, kind = 8 )
!
!  Initialize the solution estimate to 0.
!  Exact solution is (1,2,3,...,N).
!
!$omp do
  do i = 1, n
    x(i) = 0.0D+00
  end do
!$omp end do
!
!$omp end parallel
!
!  Iterate M times.
!
  do it = 1, m

!$omp parallel private ( i, t )
!
!  Jacobi update.
!
!$omp do
    do i = 1, n
      xnew(i) = b(i)
      if ( 1 < i ) then
        xnew(i) = xnew(i) + x(i-1)
      end if
      if ( i < n ) then
        xnew(i) = xnew(i) + x(i+1)
      end if
      xnew(i) = xnew(i) / 2.0D+00
    end do
!$omp end do
!
!  Difference.
!
    d = 0.0D+00
!$omp do reduction ( + : d )
    do i = 1, n
      d = d + ( x(i) - xnew(i) ) ** 2
    end do
!$omp end do
!
!  Overwrite old solution.
!
!$omp do
    do i = 1, n
      x(i) = xnew(i)
    end do
!$omp end do
!
!  Residual.
!
    r = 0.0D+00
!$omp do reduction ( + : r )
    do i = 1, n
      t = b(i) - 2.0D+00 * x(i)
      if ( 1 < i ) then
        t = t + x(i-1)
      end if
      if ( i < n ) then
        t = t + x(i+1)
      end if
      r = r + t * t
    end do
!$omp end do

!$omp master
    if ( it <= 10 .or. m - 10 <= it ) then
      write ( *, '(2x,i8,2x,g14.6,2x,g14.6)' ) it, sqrt ( d ), sqrt ( r )
    end if
    if ( it == 10 ) then
      write ( *, '(a)' ) '  Omitting intermediate results.'
    end if
!$omp end master

!$omp end parallel

  end do
!
!  Write part of final estimate.
!
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) '  Part of final solution estimate:'
  write ( *, '(a)' ) ''
  do i = 1, 10
    write ( *, '(2x,i8,2x,g14.6)' ) i, x(i)
  end do
  write ( *, '(a)' ) '...'
  do i = n - 10, n
    write ( *, '(2x,i8,2x,g14.6)' ) i, x(i)
  end do
!
!  Terminate.
!
  write ( *, '(a)' ) ''
  write ( *, '(a)' ) 'JACOBI_OPENMP:'
  write ( *, '(a)' ) '  Normal end of execution.'

  stop
end


      PROGRAM xevlmem
C     driver for routine evlmem
      INTEGER N,NFDT,M
      PARAMETER(N=1000,M=10,NFDT=16)
      INTEGER i
      REAL evlmem,fdt,pm,data(N),cof(M)
      open(7,file='SPCTRL.DAT',status='old')
      read(7,*) (data(i),i=1,N)
      close(7)
      call memcof(data,N,M,pm,cof)
      write(*,*) 'Power spectrum estimate of DATA in SPCTRL.DAT'
      write(*,'(1x,t6,a,t20,a)') 'f*delta','power'
      do 11 i=0,NFDT
        fdt=0.5*i/NFDT
        write(*,'(1x,2f12.6)') fdt,evlmem(fdt,cof,M,pm)
11    continue
      END

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


subroutine tfi2d(e0, e1, e2, e3, Nu, Nv, X)

  !***DESCRIPTION
  !
  !     Written by Gaetan Kenway
  !
  !     Abstract: Perform a simple 2D transfinite interpolation in 3
  !               spatial dimensions. This function is not used
  !               directly in pySpline, but from pyGeo.
  !
  !     Description of Arguments
  !     Input
  !     e0      - Real, Vector or coordinates along 0th edge. Size (3, Nu)
  !     e1      - Real, Vector or coordinates along 1st edge. Size (3, Nu)
  !     e2      - Real, Vector or coordinates along 2nd edge. Size (3, Nv)
  !     e3      - Real, Vector or coordinates along 3rd edge. Size (3, Nv)
  !
  !     Ouput
  !     X       - Real, Evaluated points, size 3 x Nu x Nv
  !

  use precision
  implicit none

  integer, intent(in) :: Nu,Nv
  real(kind=realType), intent(in) :: e0(3,Nu)
  real(kind=realType), intent(in) :: e1(3,Nu)

  real(kind=realType), intent(in) :: e2(3,Nv)
  real(kind=realType), intent(in) :: e3(3,Nv)

  real(kind=realType), intent(out) :: X(3,Nv,Nu)

  real(kind=realType) :: U(Nu),V(Nv)
  integer :: i,j

  do i=1,Nu
     U(i) = real(i-1)/(Nu-1)
  end do

  do j=1,Nv
     V(j) = real(j-1)/(Nv-1)
  end do

  do i=1,Nu
     do j=1,Nv
        X(:,j,i) = (1-V(j))*e0(:,i) + V(j)*e1(:,i) + &
                   (1-U(i))*e2(:,j) + U(i)*e3(:,j) - ( &
                   (  U(i))*(  V(j))*e1(:,Nu) + &
                   (  U(i))*(1-V(j))*e0(:,Nu) + &
                   (1-U(i))*(  V(j))*e1(:,1)  + &
                   (1-U(i))*(1-V(j))*e0(:,1) &
                   )
     end do
  end do

end subroutine tfi2d


program mandel

  use imageout

  implicit none

  double precision :: xmax, xmin, ymax, ymin, rmax, x0, y0, x, y, xt
  double precision :: start_t, startio_t, stop_t
  integer :: xres, yres, max_iter, iter, px, py
  integer, dimension(:,:), allocatable :: pixels

  xmax = 2.0
  xmin = -2.0

  ymax = 2.0
  ymin = -2.0

  xres = 2048
  yres = 2048

  max_iter = 256

  rmax = 2.0

  call cpu_time(start_t)

  allocate(pixels(xres,yres))

  do px = 1, xres
    x0 = ((dble(px)/dble(xres)) * dble(xmax - xmin)) + xmin

    do py = 1, yres
      y0 = ((dble(py)/dble(yres)) * dble(ymax - ymin)) + ymin
      iter = 0
      x = 0.0
      y = 0.0

      do while (((x*x + y*y) .lt. (rmax * rmax)) .and. (iter .lt. max_iter))
        xt = (x*x) - (y*y) + x0
        y = 2.0 * x * y + y0
        x = xt
        iter = iter + 1
      end do
      pixels(px,py) = max_iter - iter
    end do

  end do

  call cpu_time(startio_t)

  open(unit=24, file="mandel.pgm")
  call writepgm(pixels, xres, yres, (max_iter - 1), 24)
  close(24)
  deallocate(pixels)

  call cpu_time(stop_t)

  write(*,'(A,1F12.5,A)') "Time spent in Mandelbrot:", (startio_t - start_t), " seconds"
  write(*,'(A,1F12.5,A)') "Time spent in I/O:       ", (stop_t - startio_t), " seconds"
  write(*,'(A,1F12.5,A)') "Total:                   ", (stop_t - start_t), " seconds"
end program mandel


Program testSorting

Use Kinds, Only: dp
Use Sorting, Only: Union_Sort
Use Sorting, Only: Quick_Sort
Implicit None

Integer :: s
Integer, Allocatable :: seed(:)
Integer, Parameter :: n = 11
Real(dp) :: r_list(1:n)
Real(dp) :: r_listq(1:n)
Real(dp) :: r_listu(1:n)
Real(dp) :: r_listua(1:n)
Integer :: i
Integer :: nMax,nMaxA

Call RANDOM_SEED(SIZE=s)
Allocate(seed(1:s))
seed = 7777777
Call RANDOM_SEED(PUT=seed)
Call RANDOM_NUMBER(r_list)
r_list(5:6) = 0.3_dp
r_listq = r_list
Call Quick_Sort(r_listq)

r_listu = r_list
Call Union_Sort(r_listu,nMax)
r_listua = r_list
Call Union_Sort(r_listua,nMaxA,All = .TRUE.)
Call Write_Lists()

r_listu = r_list
Call Union_Sort(r_listu,nMax,aMin = 0.5_dp)
r_listua = r_list
Call Union_Sort(r_listua,nMaxA,aMin = 0.5_dp,All = .TRUE.)
Call Write_Lists()

r_listu = r_list
Call Union_Sort(r_listu,nMax,aMax = 0.5_dp)
r_listua = r_list
Call Union_Sort(r_listua,nMaxA,aMax = 0.5_dp,All = .TRUE.)
Call Write_Lists()

r_listu = r_list
Call Union_Sort(r_listu,nMax,aMin = 0.3_dp,aMax = 0.7_dp)
r_listua = r_list
Call Union_Sort(r_listua,nMaxA,aMin = 0.3_dp,aMax = 0.7_dp,All = .TRUE.)
Call Write_Lists()

r_listu = r_list
Call Union_Sort(r_listu,nMax,aMin = 0.3_dp,aMax = 0.7_dp,Up = .FALSE.)
r_listua = r_list
Call Union_Sort(r_listua,nMaxA,aMin = 0.3_dp,aMax = 0.7_dp,Up = .FALSE.,All = .TRUE.)
Call Write_Lists()

Contains

Subroutine Write_Lists()
    Write(*,*)
    Write(*,'(4A19)') 'r','q','ua','u'
    Do i = 1,n
        Write(*,'(2F19.15)',ADVANCE='NO') r_list(i),r_listq(i)
        If (i .LE. nMaxA) Then
            Write(*,'(F19.15)',ADVANCE='NO') r_listua(i)
        Else
            Write(*,'(A)',ADVANCE='NO') '  -----------------'
        End If
        If (i .LE. nMax) Then
            Write(*,'(F19.15)') r_listu(i)
        Else
            Write(*,'(A)') '  -----------------'
        End If
    End Do
    Write(*,'(I0,A,I0,A)') nMax,' elements in union, ',nMaxA,' elements in union-all.'
End Subroutine

End Program


!==============================================================================
! Module CONSTANTS_MODULE                                         (28-Jun-2017)
!
! Written by:
! 	   Dr. Randal J. Barnes
!     Department of Civil, Environmental, and Geo- Engineering
!     University of Minnesota
!     <barne003@umn.edu>
!==============================================================================

!==============================================================================
MODULE CONSTANTS_MODULE
!==============================================================================
   USE,INTRINSIC :: IEEE_ARITHMETIC
   IMPLICIT NONE

   !===========================================================================
   ! Micellaneous numerical constants
   !===========================================================================
   REAL(8), PARAMETER :: ONE_PI               = 3.141592653589793238462643_8
   REAL(8), PARAMETER :: TWO_PI               = 6.283185307179586476925287_8
   REAL(8), PARAMETER :: FOUR_PI              = 12.56637061435917295385057_8
   REAL(8), PARAMETER :: HALF_PI              = 1.570796326794896619231321_8
   REAL(8), PARAMETER :: SQRT_PI              = 1.772453850905516027298167_8
   REAL(8), PARAMETER :: ONE_OVER_PI          = 0.318309886183790671537767_8
   REAL(8), PARAMETER :: ONE_OVER_SQRT_PI     = 0.564189583547756286948080_8
   REAL(8), PARAMETER :: TWO_OVER_SQRT_PI     = 1.128379167095512573996160_8
   REAL(8), PARAMETER :: ONE_OVER_SQRT_TWO_PI = 0.398942280401432677939946_8
   REAL(8), PARAMETER :: EULER_GAMMA          = 0.577215664901532860606512_8

   REAL(8), PARAMETER :: DEG_TO_RAD           = ONE_PI/180.0_8
   REAL(8), PARAMETER :: RAD_TO_DEG           = 180.0_8/ONE_PI

   REAL(8), PARAMETER :: EPS                  = EPSILON(1.0_8)
   REAL(8), PARAMETER :: INFINITY             = HUGE(1.0_8)

   COMPLEX(8), PARAMETER :: CMPLX_I           = DCMPLX(0.0_8, 1.0_8)
   COMPLEX(8), PARAMETER :: TWO_PI_I          = DCMPLX(0.0_8, TWO_PI)

   !===========================================================================
   ! I/O Unit numbers
   !===========================================================================
   INTEGER, PARAMETER :: IUNIT            = 22    ! unit number for input file
   INTEGER, PARAMETER :: LUNIT            = 23    ! unit number for report file
   INTEGER, PARAMETER :: SUNIT            =  6    ! unit number for user's screen

   !===========================================================================
   ! Status flags
   !===========================================================================
   INTEGER, PARAMETER :: SUCCESS          =  1
   INTEGER, PARAMETER :: DRY_AQUIFER      = -1
   INTEGER, PARAMETER :: UNKNOWN_FAILURE  = -2
   INTEGER, PARAMETER :: DID_NOT_CONVERGE = -3

!==============================================================================
END MODULE CONSTANTS_MODULE
!==============================================================================


      SUBROUTINE polint(xa,ya,n,x,y,dy)
      INTEGER n,NMAX
      REAL dy,x,y,xa(n),ya(n)
      PARAMETER (NMAX=10)
      INTEGER i,m,ns
      REAL den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
      ns=1
      dif=abs(x-xa(1))
      do 11 i=1,n
        dift=abs(x-xa(i))
        if (dift.lt.dif) then
          ns=i
          dif=dift
        endif
        c(i)=ya(i)
        d(i)=ya(i)
11    continue
      y=ya(ns)
      ns=ns-1
      do 13 m=1,n-1
        do 12 i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.)pause 'failure in polint'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
12      continue
        if (2*ns.lt.n-m)then
          dy=c(ns+1)
        else
          dy=d(ns)
          ns=ns-1
        endif
        y=y+dy
13    continue
      return
      END

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


module class_Circle
  implicit none
  private

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

  type, public :: Circle
     real :: radius
   contains
     procedure, pass :: area => circle_area
     procedure, pass :: print => circle_print
  end type Circle

contains

  function circle_area(this) result(area)
    type(Circle), intent(in) :: this
    real :: area
    area = pi * this%radius**2
  end function circle_area

  subroutine circle_print(this)
    type(Circle), intent(in) :: this
    real :: area
    area = this%area()  ! Call the type-bound function
    print *, 'Circle: r = ', this%radius, ' area = ', area
  end subroutine circle_print

end module class_Circle

program circle_test
  use class_Circle
  implicit none

  type(Circle) :: c     ! Declare a variable of type Circle.
  c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
  call c%print          ! Call the type-bound subroutine
end program circle_test


PROGRAM vec_mat_multi_serial
  IMPLICIT NONE

  REAL(kind=8) :: t_start, t_end
  REAL(kind=8) :: temp
  INTEGER :: i, j
  INTEGER, PARAMETER :: len_vec=10000

  REAL(kind=8), ALLOCATABLE :: in_vector(:)
  REAL(kind=8), ALLOCATABLE :: out_vector(:)
  REAL(kind=8), ALLOCATABLE :: array(:,:)
  REAL(kind=8), ALLOCATABLE :: test_vec(:)

  CALL cpu_time(t_start)

  ! Allocate space for vector and array
  ALLOCATE(in_vector(len_vec))
  ALLOCATE(out_vector(len_vec))
  ALLOCATE(array(len_vec,len_vec))
  ALLOCATE(test_vec(len_vec))

  ! Initialise vector
  CALL RANDOM_NUMBER(in_vector)

  ! Initialise array
  CALL RANDOM_NUMBER(array)

  DO i=1,len_vec
     temp=0.0d+0
     DO j=1,len_vec
        temp = temp + in_vector(j)*array(j,i)
     END DO
     out_vector(i)=temp
  END DO

  test_vec = MATMUL(in_vector,array)

  test_vec = ABS(test_vec - out_vector)
  WRITE (*,'(A,3e10.5)') 'Max error: ', MAXVAL(test_vec)

  DEALLOCATE(in_vector)
  DEALLOCATE(array)
  DEALLOCATE(out_vector)
  DEALLOCATE(test_vec)

  CALL cpu_time(t_end)

  WRITE(*,'(A,f10.5)') "Expended wall clock time = ",t_end-t_start

END PROGRAM vec_mat_multi_serial


FUNCTION pythag(a,b)
IMPLICIT NONE
INTEGER, PARAMETER :: sp = 8
REAL(sp), INTENT(IN) :: a,b
REAL(sp) :: pythag
!Computes (a2 + b2)1/2 without destructive under.ow or over.ow.
REAL(sp) :: absa,absb
absa=abs(a)
absb=abs(b)
if (absa > absb) then
pythag=absa*sqrt(1.0+(absb/absa)**2)
else
if (absb == 0.0) then
pythag=0.0
else
pythag=absb*sqrt(1.0+(absa/absb)**2)
end if
end if
END FUNCTION pythag


FUNCTION gammln(xx)
REAL gammln,xx
INTEGER j
DOUBLE PRECISION ser,stp,tmp,x,y,cof(6)
SAVE cof,stp
DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,&
&24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,&
&-.5395239384953d-5,2.5066282746310005d0/
x=xx
y=x
tmp=x+5.5d0
tmp=(x+0.5d0)*log(tmp)-tmp
ser=1.000000000190015d0
do j=1,6
  y=y+1.d0
  ser=ser+cof(j)/y
enddo
gammln=tmp+log(stp*ser/x)
return
END