program typedemo
    type rational                                           ! Type declaration
        integer :: numerator
        integer :: denominator
    end type rational

    type( rational ), parameter :: zero = rational( 0, 1 )  ! Variables initialized
    type( rational ), parameter :: one  = rational( 1, 1 )  ! by constructor syntax
    type( rational ), parameter :: half = rational( 1, 2 )
    integer :: n, halfd, halfn
    type( rational ) :: &
        one_over_n(20) = (/ (rational( 1, n ), n = 1, 20) /) ! Array initialized with
                                                             ! constructor inside
                                                             ! implied-do array initializer
    integer :: oon_denoms(20)

    halfd = half%denominator                       ! field access with "%" delimiter
    halfn = half%numerator

    oon_denoms = one_over_n%denominator            ! Access denominator field in every
                                                   ! rational array element & store
end program typedemo                               ! as integer array


module mod_arrays

  ! Utility functions that operate on arrays.

  use ieee_arithmetic, only: ieee_is_finite

  implicit none

  private
  public :: denan, normalize
  public :: operator(.denan.), operator(.normalize.)

  interface denan
    module procedure :: denan_int, denan_real
  end interface denan

  interface operator(.denan.)
    module procedure :: denan_int, denan_real
  end interface operator(.denan.)

  interface operator(.normalize.)
    module procedure :: normalize
  end interface operator(.normalize.)

contains

  pure function denan_int(x) result(denan)
    ! Returns the integer array x with NaN values removed.
    ! Overloaded by the generic function denan.
    integer, intent(in) :: x(:)
    integer, allocatable :: denan(:)
    denan = pack(x, ieee_is_finite(real(x)))
  end function denan_int

  pure function denan_real(x) result(denan)
    ! Returns the real array x with NaN values removed.
    ! Overloaded by the generic function denan.
    real, intent(in) :: x(:)
    real, allocatable :: denan(:)
    denan = pack(x, ieee_is_finite(x))
  end function denan_real

  pure function normalize(x) result(res)
    ! Normalizes the values of array x to the range [0, 1].
    real, intent(in) :: x(:)
    real :: res(size(x))
    res = (x - minval(x)) / (maxval(x) - minval(x))
  end function normalize

end module mod_arrays


subroutine check_result_pair(re, im, n)
  implicit none
  integer :: i, n
  real*8 :: re(n), im(n)
  real*8 :: re_true(16), im_true(16)
  n = 16
  re_true(:)  = 0.0d0
  im_true(:)  = 0.0d0
  im_true(3)  = -8.0
  im_true(15) = +8.0

  do i = 1,n
     !write(*,'(i3,1x,f15.8,1x,f15.8)')i,re(i),im(i)
     if(abs(re_true(i) - re(i)) >= 1e-10) then
        write(*,*)'Error in fft value (re)',i,re(i),re_true(i)
        call exit(-2)
     endif
     if(abs(im_true(i) - im(i)) >= 1e-10) then
        write(*,*)'Error in fft value (im)',i,im(i),im_true(i)
        call exit(-2)
     endif
  enddo
end subroutine check_result_pair

subroutine check_result_pairf(re, im, n)
  implicit none
  integer :: i, n
  real*4 :: re(n), im(n), tol
  real*4 :: re_true(16), im_true(16)
  tol = 1e-7
  n = 16
  re_true(:)  = 0.0d0
  im_true(:)  = 0.0d0
  im_true(3)  = -8.0
  im_true(15) = +8.0

  do i = 1,n
     !write(*,'(i3,2(1x,f15.8),2(1x,e15.8))')i,re(i),im(i),abs(re(i)-re_true(i)),abs(im(i)-im_true(i))
     if(abs(re_true(i) - re(i)) >= tol) then
        write(*,*)'Error in fft value (re)',i,re(i),re_true(i)
        call exit(-2)
     endif
     if(abs(im_true(i) - im(i)) >= tol) then
        write(*,*)'Error in fft value (im)',i,im(i),im_true(i)
        call exit(-2)
     endif
  enddo
end subroutine check_result_pairf

subroutine check_result_complex(z, n)
  implicit none
  integer :: i, n
  complex*16 :: z(n)
  real*8 :: re(n), im(n)
  do i = 1,n
     re(i) = real(z(i))
     im(i) = imag(z(i))
  enddo
  call check_result_pair(re, im, n)
end subroutine check_result_complex

subroutine check_result_complexf(z, n)
  implicit none
  integer :: i, n
  complex*8 :: z(n)
  real*4 :: re(n), im(n)
  do i = 1,n
     re(i) = real(z(i))
     im(i) = imag(z(i))
  enddo
  call check_result_pairf(re, im, n)
end subroutine check_result_complexf

subroutine check_dataf(a, b, n)
  integer n
  real*4 :: a(n),b(n),tol
  tol = 1e-7
  do i = 1,n
     if(abs(a(i) - b(i)) >= tol) then
        write(*,*)'Error in data value',i,a(i),b(i)
     endif
  end do
end subroutine check_dataf

subroutine check_data(a, b, n)
  integer n
  real*8 :: a(n),b(n),tol
  tol = 1e-10
  do i = 1,n
     if(abs(a(i) - b(i)) >= tol) then
        write(*,*)'Error in data value',i,a(i),b(i)
     endif
  end do
end subroutine check_data

subroutine fft_double()

  implicit none

  integer i, n, nf
  real*8 :: data(16),data2(16)
  real*8 :: pi
  real*8 :: re(16), im(16)
  complex*16 :: z(16)
  real*8, allocatable :: rea(:), ima(:)
  complex*16, allocatable :: za(:)
  n = 16
  nf = 16
  pi = acos(-1.0d0);
  ! Sine wave - Input
  do i = 1,n
     data(i) = sin( (i-1) * 2.0 * pi / (n / 2.0))
  enddo

  ! FFT
  call dfft(data, n, re, im, nf)
  call check_result_pair(re, im, nf)
  call idfft(data2, n, re, im, nf)
  call check_data(data, data2, n);

  ! FFT with complex number
  call dfftz(data, n, z, nf)
  call check_result_complex(z, nf)
  call idfftz(data2, n, z, nf)
  call check_data(data, data2,n );

  ! FFT with allocated complex number
  ! Get next/bounding power of 2
  nf = 2
  do while (nf < n)
     nf = nf * 2
  enddo
  allocate(za(n))
  call dfftz(data, n, za, nf)
  call check_result_complex(za, nf)
  deallocate(za)

  ! FFT
  nf = 2
  do while (nf < n)
     nf = nf * 2
  enddo
  allocate(rea(n))
  allocate(ima(n))
  call dfft(data, n, rea, ima, nf)
  call check_result_pair(rea, ima, nf)
  deallocate(rea)
  deallocate(ima)

end subroutine fft_double

subroutine fft_single()

  implicit none

  integer i, n, nf
  real*4 :: data(16),data2(16)
  real*8 :: pi
  real*4 :: re(16), im(16)
  complex*8 :: z(16)
  real*4, allocatable :: rea(:), ima(:)
  complex*8, allocatable :: za(:)
  n = 16
  pi = acos(-1.0d0);
  ! Sine wave - Input
  do i = 1,n
     data(i) = sin( (i-1) * 2.0 * pi / (n / 2.0))
  enddo

  ! FFT
  call fft(data, n, re, im, nf)
  call check_result_pairf(re, im, nf)
  call ifft(data2, n, re, im, nf)
  call check_dataf(data, data2, n)

  ! FFT with complex number
  call fftz(data, n, z, nf)
  call check_result_complexf(z, nf)
  call ifftz(data2, n, z, nf)
  call check_dataf(data, data2, n)

  ! FFT with allocated complex number
  ! Get next/bounding power of 2
  nf = 2
  do while (nf < n)
     nf = nf * 2
  enddo
  allocate(za(n))
  call fftz(data, n, za, nf)
  call check_result_complexf(za, nf)
  call ifftz(data2, n, z, nf)
  call check_dataf(data, data2, n)
  deallocate(za)

  ! FFT
  nf = 2
  do while (nf < n)
     nf = nf * 2
  enddo
  allocate(rea(n))
  allocate(ima(n))
  call fft(data, n, rea, ima, nf)
  call check_result_pairf(rea, ima, nf)
  call ifft(data2, n, re, im, nf)
  call check_dataf(data, data2, n)
  deallocate(rea)
  deallocate(ima)

end subroutine fft_single

program fftf
  implicit none
  call fft_double()
  call fft_single()
end program fftf


      REAL(KIND(0.0D0)) FUNCTION plgndr(l,m,x)
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)      :: L, M
      REAL(DOUBLE), INTENT(IN) :: x
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!----------------------------------------------
      INTEGER      :: i, ll
      REAL(DOUBLE) :: fact,pll,pmm,pmmp1,somx2
!----------------------------------------------
!
!GG      if(m.lt.0.or.m.gt.l.or.abs(x).gt.1.d0)pause                      &
!GG                                              'bad arguments in plgndr'
      if(m.lt.0.or.m.gt.l.or.abs(x).gt.1.d0) then
         print*, "bad arguments in plgndr"
         stop
      end if
      pmm=1.d0
!                m
!     Compute   P
!                m
      if(m.gt.0) then
        somx2=sqrt((1.d0-x)*(1.d0+x))
        fact=1.d0
        do 11 i=1,m
          pmm=-pmm*fact*somx2
          fact=fact+2.d0
11      continue
      endif
      if(l.eq.m) then
        plgndr=pmm
      else
        pmmp1=x*(2*m+1)*pmm
!                m
!     Compute   P
!                m+1
        if(l.eq.m+1) then
          plgndr=pmmp1
        else
!                m
!     Compute   P  ,  l > m+1
!                l
          do 12 ll=m+2,l
            pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
            pmm=pmmp1
            pmmp1=pll
12        continue
          plgndr=pll
        endif
      endif
      return
      END FUNCTION plgndr
!  (C) Copr. 1986-92 Numerical Recipes Software oV)#S.


MODULE Procedures

USE Params
USE Globals

IMPLICIT NONE
CONTAINS

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

double precision FUNCTION EZAGG(lx,ly)
double precision, INTENT(in)	::  lx,ly

IF(sigC==1.0) THEN
	EZAGG = (lx**(1.0-bet)) * (ly**bet)
ELSE
	EZAGG = ((1.0-bet)*(lx**(1.0-sigC)) + bet*(ly**(1.0-sigC))) ** (1.0/(1.0-sigC))
END IF

END FUNCTION EZAGG

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

double precision FUNCTION INVEZ(lx)
double precision, INTENT(in)	::  lx

IF(gamC==1.0) THEN
	INVEZ = exp((1-bet)*lx)
ELSE
	INVEZ = (lx*(1.0-gamC)) **(1.0/(1.0-gamC))
END IF

END FUNCTION INVEZ
!-----------------------------------------------

double precision FUNCTION EZ(lx)
double precision, INTENT(in)	::  lx

IF(gamC==1.0) THEN
	EZ = log(lx)/(1.0-bet)
ELSE
	EZ = (lx**(1.0-gamC))/ (1.0-gamC)
END IF

END FUNCTION EZ

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

SUBROUTINE ReverseVector(n,xin,xout)
IMPLICIT NONE
INTEGER, INTENT(in)		:: n
double precision, INTENT(in)		:: xin(n)
double precision, INTENT(out)	:: xout(n)
INTEGER					:: i
double precision					:: lxin(n),lxout(n)

lxin = xin
DO i = 1,n
	lxout(i) = lxin(n-i+1)
END DO
xout = lxout

END SUBROUTINE ReverseVector
!-----------------------------------------------

SUBROUTINE LinInterp (n,x,y,ni,xi,yi)
!this does linear interpolation of (x,y) at points xi
!requires x to be sorted in ascending order
!extrapolates out of range
IMPLICIT NONE
INTEGER, INTENT(in)		:: n,ni
double precision, INTENT(in)	:: x(:),y(:),xi(:)
double precision, INTENT(out)	:: yi(:)
double precision, DIMENSION(ni)	:: xL,xH,yL,yH
INTEGER					:: i,locL(ni)

DO i = 1,ni

	LocL(i) = MAXLOC(x,1,MASK=xi(i)>x)

	IF (xi(i)<=x(1)) THEN
		LocL(i) = 1
	END IF

	IF (LocL(i)>=n) THEN
		LocL(i) = n-1
	END IF

	xL(i) = x(locL(i))
	xH(i) = x(locL(i)+1)
	yL(i) = y(locL(i))
	yH(i) = y(locL(i)+1)

	yi(i) = yL(i) + (xi(i)-xL(i))*((yH(i)-yL(i))/(xH(i)-xL(i)))

END DO

END SUBROUTINE LinInterp

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

SUBROUTINE LinInterp1 (n,x,y,xi,yi)
!this does linear interpolation of (x,y) at points only point,xi
!requires x to be sorted in ascending order
!extrapolates out of range
IMPLICIT NONE
INTEGER, INTENT(in)		:: n
double precision, INTENT(in)	:: x(:),y(:),xi
double precision, INTENT(out)	:: yi
double precision	            :: xL,xH,yL,yH
INTEGER					:: locL

LocL = MAXLOC(x,1,MASK=xi>x)

IF (xi<=x(1)) THEN
	LocL = 1
END IF

IF (LocL>=n) THEN
	LocL = n-1
END IF

xL  = x(locL)
xH  = x(locL +1)
yL  = y(locL)
yH  = y(locL +1)

yi  = yL  + (xi -xL )*((yH -yL )/(xH -xL ))

END SUBROUTINE LinInterp1

!----------------------------------------------
SUBROUTINE WriteVector(f,iL,iH,mat)

INTEGER, INTENT(IN)			:: f,iL,iH
double precision,INTENT(in)		:: mat(iL:iH)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') 1
lstring = '('//trim(lstring) // 'F16.6)'
DO i1=iL,iH
	WRITE(f,lstring) mat(i1)
END DO

CLOSE(f)

END SUBROUTINE WriteVector
!----------------------------------------------
SUBROUTINE WriteVectorInteger(f,iL,iH,mat)

INTEGER, INTENT(IN)			:: f,iL,iH
INTEGER, INTENT(in)		:: mat(iL:iH)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') 1
lstring = '('//trim(lstring) // 'I16)'
DO i1=iL,iH
	WRITE(f,lstring) mat(i1)
END DO

CLOSE(f)

END SUBROUTINE WriteVectorInteger
!----------------------------------------------
SUBROUTINE WriteMatrix(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2
lstring = '('//trim(lstring) // 'F16.6)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrix
!----------------------------------------------
SUBROUTINE WriteMatrix2(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1,i2

WRITE(UNIT=lstring, FMT='(I5)') 1
lstring = '('//trim(lstring) // 'F16.6)'
DO i1=1,n1
    do i2=1,n2

    WRITE(f,lstring) (mat(i1,i2))
    END DO
END DO
CLOSE(f)

END SUBROUTINE WriteMatrix2

!----------------------------------------------
SUBROUTINE WriteMatrix3(f,n1,n2,n3,mat)

INTEGER, INTENT(IN)			:: f,n1,n2,n3
double precision,INTENT(in)		:: mat(n1,n2,n3)
CHARACTER		::lstring*80
INTEGER			::i3,i2

WRITE(UNIT=lstring, FMT='(I5)') n1
lstring = '('//trim(lstring) // 'F16.6)'
DO i3=1,n3
    DO i2=1,n2
    	WRITE(f,lstring) (mat(:,i2,i3))
    END DO
END DO

CLOSE(f)

END SUBROUTINE WriteMatrix3
!----------------------------------------------
SUBROUTINE WriteMatrixLH(f,iL,iH,n2,mat)
!same as write matrix but allows the indices of the first dimension to be different from 1:n1
INTEGER, INTENT(IN)			:: f,n2,iL,iH
double precision,INTENT(in)		:: mat(iL:iH,1:n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2
lstring = '('//trim(lstring) // 'F16.6)'
DO i1=iL,iH
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixLH
!----------------------------------------------
SUBROUTINE WriteMatrixLong(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2
lstring = '('//trim(lstring) // 'F20.14)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixLong
!----------------------------------------------
SUBROUTINE WriteMatrixExpon(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2
lstring = '('//trim(lstring) // 'E16.8)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixExpon
!----------------------------------------------
SUBROUTINE WriteMatrixCSVExpon(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2-1
lstring = '('//trim(lstring) // '(E16.8,","),E16.8)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixCSVExpon
!----------------------------------------------
SUBROUTINE WriteMatrixInteger(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
INTEGER,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2
lstring = '('//trim(lstring) // 'I16)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixInteger
!----------------------------------------------
SUBROUTINE WriteMatrixCSV(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
double precision,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2-1
lstring = '('//trim(lstring) // '(F16.6,","),F16.6)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixCSV
!----------------------------------------------
SUBROUTINE WriteMatrixCSVInteger(f,n1,n2,mat)

INTEGER, INTENT(IN)			:: f,n1,n2
INTEGER,INTENT(in)		:: mat(n1,n2)
CHARACTER		::lstring*80
INTEGER			::i1

WRITE(UNIT=lstring, FMT='(I5)') n2-1
lstring = '('//trim(lstring) // '(I16,","),I16)'
DO i1=1,n1
	WRITE(f,lstring) (mat(i1,:))
END DO

CLOSE(f)

END SUBROUTINE WriteMatrixCSVInteger
!----------------------------------------------

SUBROUTINE RandomDiscrete(Nout,Xout,Nin,Pin)
!generates Nout random draws from the integers 1 to Nin
!using probabilities in Pin
IMPLICIT NONE
INTEGER, INTENT(in)			:: Nout,Nin
INTEGER,INTENT(out)		:: Xout(:)
double precision, INTENT(in)  :: Pin(:)

INTEGER			::i1,i2
double precision      :: lran(Nout)

!IF(sum(Pin) .ne. 1.0) write(*,*) 'error in RandomDiscrete: Pin doesnt sum to 1.0'

CALL RANDOM_NUMBER(lran)

Xout(:) = 0
DO i1 = 1,Nout
    IF ( lran(i1) .le. Pin(1) ) THEN
        Xout(i1) = 1
    ELSE
        i2 = 2
        DO WHILE (i2 .le. Nin)
            IF ( (lran(i1) .le. SUM(Pin(1:i2)) ).and. (lran(i1) > SUM(Pin(1:i2-1)) ) ) THEN
                Xout(i1) = i2
                i2 = Nin+1
            ELSE
                i2 = i2+1
            END IF
        END DO
    END IF
END DO

END SUBROUTINE RandomDiscrete

!--------------------------------------------------------------
SUBROUTINE RandomDiscrete1(Xout,Nin,Pin)
!generates Nout random draws from the integers 1 to Nin
!using probabilities in Pin
IMPLICIT NONE
INTEGER, INTENT(in)			:: Nin
INTEGER,INTENT(out)		:: Xout
double precision, INTENT(in)  ::Pin(:)

INTEGER			::i2
double precision      :: lran

!IF(sum(Pin) .ne. 1.0) write(*,*) 'error in RandomDiscrete: Pin doesnt sum to 1.0'

CALL RANDOM_NUMBER(lran)

Xout = 0
IF ( lran .le. Pin(1) ) THEN
    Xout = 1
ELSE
    i2 = 2
    DO WHILE (i2 .le. Nin)
        IF ( (lran .le. SUM(Pin(1:i2)) ).and. (lran > SUM(Pin(1:i2-1)) ) ) THEN
            Xout = i2
            i2 = Nin+1
        ELSE
            i2 = i2+1
        END IF
    END DO
END IF

END SUBROUTINE RandomDiscrete1

!----------------------------------------------
SUBROUTINE DiscreteDist(Nout,Xout,Nin,Pin,lran)
!takes in random numbers and a prob dist over the integers 1 to Nin
!and returns the corresponding values
!Created 11/22/09 - ERS

INTEGER,    INTENT(out) :: Xout(:)
INTEGER,    INTENT(in)  :: Nin,Nout
double precision,    INTENT(in)  :: Pin(:)
double precision, INTENT(in)  :: lran(:)
INTEGER			        :: i1,i2

Xout(:) = 0
DO i1 = 1,Nout
    IF ( lran(i1) .le. Pin(1) ) THEN
        Xout(i1) = 1
    ELSE
        i2 = 2
        DO WHILE (i2 .le. Nin)
            IF ( (lran(i1) .le. SUM(Pin(1:i2)) ).and. (lran(i1) > SUM(Pin(1:i2-1)) ) ) THEN
                Xout(i1) = i2
                i2 = Nin+1
            ELSE
                i2 = i2+1
            END IF
        END DO
    END IF
END DO

END SUBROUTINE DiscreteDist

!-----------------------------------------------
SUBROUTINE DiscreteDist1(Xout,Nin,Pin,lran)
!takes in a random number and a prob dist over the integers 1 to Nin
!and returns the corresponding value

INTEGER, INTENT(in)     :: Nin
INTEGER,INTENT(out)     :: Xout
double precision, INTENT(in)     :: Pin(:),lran
INTEGER                 :: i2

Xout = 0
IF ( lran .le. Pin(1) ) THEN
   Xout = 1
ELSE
   i2 = 2
   DO WHILE (i2 .le. Nin)
       IF ( (lran .le. SUM(Pin(1:i2)) ).and. (lran > SUM(Pin(1:i2-1)) ) ) THEN
           Xout = i2
           i2 = Nin+1
       ELSE
           i2 = i2+1
       END IF
   END DO
END IF

END SUBROUTINE DiscreteDist1

!-----------------------------------------------
!--------------------------------------------------------------
RECURSIVE SUBROUTINE quick_sort(list, order)

! Quick sort routine from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
! Modified by Alan Miller to include an associated integer array which gives
! the positions of the elements in the original order.

IMPLICIT NONE
double precision, DIMENSION (:), INTENT(IN OUT)  :: list
INTEGER, DIMENSION (:), INTENT(OUT)  :: order

! Local variable
INTEGER :: i

DO i = 1, SIZE(list)
  order(i) = i
END DO

CALL quick_sort_1(1, SIZE(list))

CONTAINS

RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)

INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
double precision                :: reference, temp
INTEGER, PARAMETER  :: max_simple_sort_size = 6

IF (right_end < left_end + max_simple_sort_size) THEN
  ! Use interchange sort for small lists
  CALL interchange_sort(left_end, right_end)

ELSE
  ! Use partition ("quick") sort
  reference = list((left_end + right_end)/2)
  i = left_end - 1; j = right_end + 1

  DO
    ! Scan list from left end until element >= reference is found
    DO
      i = i + 1
      IF (list(i) >= reference) EXIT
    END DO
    ! Scan list from right end until element <= reference is found
    DO
      j = j - 1
      IF (list(j) <= reference) EXIT
    END DO

    IF (i < j) THEN
      ! Swap two out-of-order elements
      temp = list(i); list(i) = list(j); list(j) = temp
      itemp = order(i); order(i) = order(j); order(j) = itemp
    ELSE IF (i == j) THEN
      i = i + 1
      EXIT
    ELSE
      EXIT
    END IF
  END DO

  IF (left_end < j) CALL quick_sort_1(left_end, j)
  IF (i < right_end) CALL quick_sort_1(i, right_end)
END IF

END SUBROUTINE quick_sort_1

SUBROUTINE interchange_sort(left_end, right_end)
IMPLICIT NONE
INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL                :: temp

DO i = left_end, right_end - 1
  DO j = i+1, right_end
    IF (list(i) > list(j)) THEN
      temp = list(i); list(i) = list(j); list(j) = temp
      itemp = order(i); order(i) = order(j); order(j) = itemp
    END IF
  END DO
END DO

END SUBROUTINE interchange_sort

END SUBROUTINE quick_sort
!-----------------------------------------------------------------------
SUBROUTINE Percentile(n,x,p,q)
IMPLICIT NONE
INTEGER, INTENT(in)		:: n
double precision, INTENT(in)	:: x(n),p
double precision, INTENT(out)	:: q
double precision				:: lx(n),li,lx1,lx2
INTEGER					:: lxord(n),i1,i2

lx = x
li = (n+1)*p
i1 = dint(li)
i2 = i1+1
CALL quick_sort(lx,lxord)
lx1 = lx(i1)
lx2 = lx(i2)

q  = lx1  + (li -real(i1) )*((lx2 -lx1 )/real(i2 -i1 ))

END SUBROUTINE Percentile

!-----------------------------------------------------------------------
SUBROUTINE Rouwenhorst(n,p,q,R)
IMPLICIT NONE
INTEGER, INTENT(in)		:: n
double precision, INTENT(in)	:: p,q
double precision, INTENT(out)	:: R(n,n)
double precision				:: X(n,n), Y1(n,n), Y2(n,n), Y3(n,n), Y4(n,n)
INTEGER					:: j,i

X(1,1) = p
X(1,2) = 1-p
X(2,1) = 1-q
X(2,2) = q

IF(n>2) THEN
DO j = 2,n-1
	Y1(:,:) = 0.0
	Y2(:,:) = 0.0
	Y3(:,:) = 0.0
	Y4(:,:) = 0.0
	Y1(1:j,1:j) = X(1:j,1:j)
	Y2(1:j,2:j+1) = X(1:j,1:j)
	Y3(2:j+1,1:j) = X(1:j,1:j)
	Y4(2:j+1,2:j+1) = X(1:j,1:j)
	X = p*Y1 + (1-p)*Y2 + (1-q)*Y3 + q*Y4
	DO i = 2,j
		X(i,:) = X(i,:)/2.0
	END DO
END DO

END IF
R = X

END SUBROUTINE Rouwenhorst

SUBROUTINE FindLeftCross (n1,x1,y1,n2,x2,y2,xout)
!for two vectors with y1(1)>y2(1), it finds first point x where y2(x)>=x2(x)
IMPLICIT NONE
INTEGER, INTENT(in)		:: n1,n2
double precision, INTENT(in)	:: x1(n1),y1(n1),x2(n2),y2(n2)
double precision, INTENT(out)	:: xout
double precision	            :: y2atx1(n1), y1atx2(n2),x(n1+n2),ydiff(n1+n2),ydiffsort(n1+n2),xL,xH,yL,yH
INTEGER					:: i,order(n1+n2)

!first check for no left cross point
! IF (y1(1)<=y2(1)) THEN
! 	write(*,*) 'err in FindLeftCross: y2>y1 at start'
! 	return
! END IF

!THERE MUST BE A MORE EFFICIENT WAY!
!interpolate y2 at each point in n1 to find where cross
CALL LinInterp (n2,x2,y2,n1,x1,y2atx1)
!interpolate y1 at each point in n2 to find where cross
CALL LinInterp (n1,x1,y1,n2,x2,y1atx2)

!combines the two vectors
DO i = 1,n1+n2
	x(1:n1) = x1
	ydiff(1:n1) = y1-y2atx1
	x(n1+1:n1+n2) = x2
	ydiff(n1+1:n1+n2) = y1atx2-y2
END DO

CALL quick_sort(x, order)
DO i =1,n1+n2
	ydiffsort(i) = ydiff(order(i))
END DO

DO i = 1,n1+n2
	IF (ydiffsort(i)<=0.0) GOTO 10
END DO
IF(i == n1+n2+1) THEN
	!write(*,*)'problem in FindLeftCross: no crossing'
	!for all reasonable cash levels adjusting is better, perhaps if assets are really high
	xout = 999.99
	return
END IF

10 xH = ydiffsort(i)
yH = x(i)

IF(i>1) THEN
	xL = ydiffsort(i-1)
	yL = x(i-1)
ELSE
	write(*,*)'prob in FindLeftCross: ydiff<=0 at first point'
	!need to extrapolate
	xL = ydiffsort(1)
	yL = x(1)

	xH = ydiffsort(2)
	yH = x(2)
	!xout = -100.0

	!return
END IF

xout  = yL   -xL *((yH -yL )/(xH -xL ))

END SUBROUTINE FindLeftCross

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

SUBROUTINE PowerSpacedGrid (n,k,low,high,y)

!gives a grid spaced between low and high based on the unit interval with a function x^(1/k)
!k = 1 is linear, k = 0 is L-shaped

IMPLICIT NONE

INTEGER, INTENT(in)	:: n
double precision, INTENT(in)	:: k,low,high
double precision, INTENT(out) :: y(:)
INTEGER				:: i
double precision				:: x(n),z(n)

IF(n<2) THEN
	write(*,*) 'n must be at least 2 to make grids'
	return
END IF

IF (n==2) THEN
	y(1) = low
	y(2) = high
	return
END IF

x(1) = 0.0
x(n) = 1.0
DO i = 2,n-1
	x(i) = (i-1)/real(n-1)
END DO

z = x**(1.0/k)

y = low + (high-low)*z

END SUBROUTINE PowerSpacedGrid

SUBROUTINE OLS(n,k,x,y,beta)

!x is n x k
!y is n x 1
!beta is k x 1
IMPLICIT NONE
INTEGER, INTENT(in)		:: n,k
DOUBLE PRECISION, INTENT(in)		:: x(n,k),y(n)
DOUBLE PRECISION, INTENT(out)	:: beta(k)
DOUBLE PRECISION					:: lxx(k,k),lxxinv(k,k)
INTEGER					:: ierr

lxx = matmul(transpose(x),x)
CALL InvertMatrix(lxx, lxxinv, k, ierr)
beta = matmul(lxxinv,matmul(transpose(x),y))

END SUBROUTINE OLS

   subroutine spline (x, y, b, c, d, n)
!======================================================================
!  Calculate the coefficients b(i), c(i), and d(i), i=1,2,...,n
!  for cubic spline interpolation
!  s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
!  for  x(i) <= x <= x(i+1)
!  Alex G: January 2010
!----------------------------------------------------------------------
!  input..
!  x = the arrays of data abscissas (in strictly increasing order)
!  y = the arrays of data ordinates
!  n = size of the arrays xi() and yi() (n>=2)
!  output..
!  b, c, d  = arrays of spline coefficients
!  comments ...
!  spline.f90 program is based on fortran version of program spline.f
!  the accompanying function fspline can be used for interpolation
!======================================================================
implicit none
integer n
double precision x(n), y(n), b(n), c(n), d(n)
integer i, j, gap
double precision h

gap = n-1
! check input
if ( n < 2 ) return
if ( n < 3 ) then
  b(1) = (y(2)-y(1))/(x(2)-x(1))   ! linear interpolation
  c(1) = 0.
  d(1) = 0.
  b(2) = b(1)
  c(2) = 0.
  d(2) = 0.
  return
end if
!
! step 1: preparation
!
d(1) = x(2) - x(1)
c(2) = (y(2) - y(1))/d(1)
do i = 2, gap
  d(i) = x(i+1) - x(i)
  b(i) = 2.0*(d(i-1) + d(i))
  c(i+1) = (y(i+1) - y(i))/d(i)
  c(i) = c(i+1) - c(i)
end do
!
! step 2: end conditions
!
b(1) = -d(1)
b(n) = -d(n-1)
c(1) = 0.0
c(n) = 0.0
if(n /= 3) then
  c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
  c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
  c(1) = c(1)*d(1)**2/(x(4)-x(1))
  c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
end if
!
! step 3: forward elimination
!
do i = 2, n
  h = d(i-1)/b(i-1)
  b(i) = b(i) - h*d(i-1)
  c(i) = c(i) - h*c(i-1)
end do
!
! step 4: back substitution
!
c(n) = c(n)/b(n)
do j = 1, gap
  i = n-j
  c(i) = (c(i) - d(i)*c(i+1))/b(i)
end do
!
! step 5: compute spline coefficients
!
b(n) = (y(n) - y(gap))/d(gap) + d(gap)*(c(gap) + 2.0*c(n))
do i = 1, gap
  b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.0*c(i))
  d(i) = (c(i+1) - c(i))/d(i)
  c(i) = 3.*c(i)
end do
c(n) = 3.0*c(n)
d(n) = d(n-1)
end subroutine spline

  function ispline(u, x, y, b, c, d, n)
!======================================================================
! function ispline evaluates the cubic spline interpolation at point z
! ispline = y(i)+b(i)*(u-x(i))+c(i)*(u-x(i))**2+d(i)*(u-x(i))**3
! where  x(i) <= u <= x(i+1)
!----------------------------------------------------------------------
! input..
! u       = the abscissa at which the spline is to be evaluated
! x, y    = the arrays of given data points
! b, c, d = arrays of spline coefficients computed by spline
! n       = the number of data points
! output:
! ispline = interpolated value at point u
!=======================================================================
implicit none
double precision ispline
integer n
double precision  u, x(n), y(n), b(n), c(n), d(n)
integer i, j, k
double precision dx

! if u is ouside the x() interval take a boundary value (left or right)
if(u <= x(1)) then
  ispline = y(1)
  return
end if
if(u >= x(n)) then
  ispline = y(n)
  return
end if

!*
!  binary search for for i, such that x(i) <= u <= x(i+1)
!*
i = 1
j = n+1
do while (j > i+1)
  k = (i+j)/2
  if(u < x(k)) then
    j=k
    else
    i=k
   end if
end do
!*
!  evaluate spline interpolation
!*
dx = u - x(i)
ispline = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
end function ispline

END MODULE Procedures


        subroutine idd_id2svd(m,krank,b,n,list,proj,u,v,s,ier,w)
c
c       converts an approximation to a matrix in the form of an ID
c       to an approximation in the form of an SVD.
c
c       input:
c       m -- first dimension of b
c       krank -- rank of the ID
c       b -- columns of the original matrix in the ID
c       list -- list of columns chosen from the original matrix
c               in the ID
c       n -- length of list and part of the second dimension of proj
c       proj -- projection coefficients in the ID
c
c       output:
c       u -- left singular vectors
c       v -- right singular vectors
c       s -- singular values
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       work:
c       w -- must be at least (krank+1)*(m+3*n)+26*krank**2 real*8
c            elements long
c
c       _N.B._: This routine destroys b.
c
        implicit none
        integer m,krank,n,list(n),iwork,lwork,ip,lp,it,lt,ir,lr,
     1          ir2,lr2,ir3,lr3,iind,lind,iindt,lindt,lw,ier
        real*8 b(m,krank),proj(krank,n-krank),u(m,krank),v(n,krank),
     1         w((krank+1)*(m+3*n)+26*krank**2),s(krank)
c
c
        lw = 0
c
        iwork = lw+1
        lwork = 25*krank**2
        lw = lw+lwork
c
        ip = lw+1
        lp = krank*n
        lw = lw+lp
c
        it = lw+1
        lt = n*krank
        lw = lw+lt
c
        ir = lw+1
        lr = krank*n
        lw = lw+lr
c
        ir2 = lw+1
        lr2 = krank*m
        lw = lw+lr2
c
        ir3 = lw+1
        lr3 = krank*krank
        lw = lw+lr3
c
        iind = lw+1
        lind = n/2+1
        lw = lw+1
c
        iindt = lw+1
        lindt = m/2+1
        lw = lw+1
c
c
        call idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                   w(iwork),w(ip),w(it),w(ir),w(ir2),w(ir3),
     2                   w(iind),w(iindt))
c
c
        return
        end
c
c
c
c


SUBROUTINE TESTUNITARITY(N,U,DELTA,INFO)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: N
  COMPLEX*16, DIMENSION(N,N), INTENT(IN) :: U_F
  INTEGER, INTENT(INOUT) :: INFO
  DOUBLE PRECISION, INTENT(OUT) :: DELTA

  DOUBLE PRECISION, DIMENSION(N,N) :: P
  INTEGER i_

  P = MATMUL(TRANSPOSE(CONJG(U_F)),U_F))

  DELTA = 0.0

  DO i_=1,N

     DELTA = DELTA  +  ABS(P(i_,i_) - 1.0)

  END DO

END SUBROUTINE TESTUNITARITY


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

    Module dgeesx_example_mod

!     DGEESX Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public :: select
!     .. Parameters ..
      Integer, Parameter, Public :: nb = 64, nin = 5, nout = 6
      Logical, Parameter, Public :: check_fac = .True., print_cond = .False.
    Contains
      Function select(wr, wi)

!       Logical function select for use with DGEESX (DGEESX)
!       Returns the value .TRUE. if the eigenvalue is real and positive

!       .. Function Return Value ..
        Logical :: select
!       .. Scalar Arguments ..
        Real (Kind=dp), Intent (In) :: wi, wr
!       .. Executable Statements ..
        select = (wr>0._dp .And. wi==0._dp)
        Return
      End Function
    End Module
    Program dgeesx_example

!     DGEESX Example Main Program

!     .. Use Statements ..
      Use blas_interfaces, Only: dgemm
      Use dgeesx_example_mod, Only: check_fac, nb, nin, nout, print_cond, select
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgeesx, dlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=dp) :: alpha, anorm, beta, eps, norm, rconde, rcondv, tol
      Integer :: i, ifail, info, lda, ldc, ldd, ldvs, liwork, lwork, n, sdim
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), c(:, :), d(:, :), vs(:, :), &
        wi(:), work(:), wr(:)
      Real (Kind=dp) :: dummy(1)
      Integer :: idum(1)
      Integer, Allocatable :: iwork(:)
      Logical, Allocatable :: bwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGEESX Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      ldd = n
      ldvs = n
      Allocate (a(lda,n), c(ldc,n), d(ldd,n), vs(ldvs,n), wi(n), wr(n), &
        bwork(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      Call dgeesx('Vectors (Schur)', 'Sort', select, &
        'Both reciprocal condition numbers', n, a, lda, sdim, wr, wi, vs, &
        ldvs, rconde, rcondv, dummy, lwork, idum, liwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      liwork = max((n*n)/4, idum(1))
      lwork = max(n*(nb+2+n/2), nint(dummy(1)))
      Allocate (work(lwork), iwork(liwork))

!     Read in the matrix A
      Read (nin, *)(a(i,1:n), i=1, n)

!     Copy A into D
      d(1:n, 1:n) = a(1:n, 1:n)

!     Print matrix A
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Matrix A', ifail)

      Write (nout, *)
      Flush (nout)

!     Find the Frobenius norm of A
      anorm = dlange('Frobenius', n, n, a, lda, work)

!     Find the Schur factorization of A
      Call dgeesx('Vectors (Schur)', 'Sort', select, &
        'Both reciprocal condition numbers', n, a, lda, sdim, wr, wi, vs, &
        ldvs, rconde, rcondv, work, lwork, iwork, liwork, bwork, info)

      If (info/=0 .And. info/=(n+2)) Then
        Write (nout, 170) 'Failure in DGEESX. INFO =', info
        Go To 100
      End If

      If (check_fac) Then
!       Compute A - Z*T*Z^T from the factorization of A and store in matrix D
        alpha = 1.0_dp
        beta = 0.0_dp
        Call dgemm('N', 'N', n, n, n, alpha, vs, ldvs, a, lda, beta, c, ldc)
        alpha = -1.0_dp
        beta = 1.0_dp
        Call dgemm('N', 'T', n, n, n, alpha, c, ldc, vs, ldvs, beta, d, ldd)

!       Find norm of matrix D and print warning if it is too large
        norm = dlange('O', ldd, n, d, ldd, work)
        If (norm>epsilon(1.0E0_dp)**0.8_dp) Then
          Write (nout, *) 'Norm of A-(Z*T*Z^T) is much greater than 0.'
          Write (nout, *) 'Schur factorization has failed.'
          Go To 100
        End If
      End If

!     Print solution
      Write (nout, 110) 'Number of eigenvalues for which SELECT is true = ', &
        sdim, '(dimension of invariant subspace)'

      Write (nout, *)
!     Print eigenvalues.
      Write (nout, *) 'Selected eigenvalues'
      Write (nout, 120)(' (', wr(i), ',', wi(i), ')', i=1, sdim)
      Write (nout, *)

      If (info==(n+2)) Then
        Write (nout, 130) '***Note that rounding errors mean ', &
          'that leading eigenvalues in the Schur form', &
          'no longer satisfy SELECT = .TRUE.'
        Write (nout, *)
      End If
      Flush (nout)

      If (print_cond) Then
!       Print out the reciprocal condition numbers
        Write (nout, 140) 'Reciprocal of projection norm onto the invariant', &
          'subspace for the selected eigenvalues', 'RCONDE = ', rconde
        Write (nout, *)
        Write (nout, 150) &
          'Reciprocal condition number for the invariant subspace', &
          'RCONDV = ', rcondv

!       Compute the machine precision
        eps = epsilon(1.0E0_dp)
        tol = eps*anorm

!       Print out the approximate asymptotic error bound on the
!       average absolute error of the selected eigenvalues given by
!       eps*norm(A)/RCONDE
        Write (nout, *)
        Write (nout, 160) 'Approximate asymptotic error bound for selected ', &
          'eigenvalues   = ', tol/rconde

!       Print out an approximate asymptotic bound on the maximum
!       angular error in the computed invariant subspace given by
!       eps*norm(A)/RCONDV
        Write (nout, 160) &
          'Approximate asymptotic error bound for the invariant ', &
          'subspace = ', tol/rcondv
      End If
100   Continue

110   Format (1X, A, I4, /, 1X, A)
120   Format (1X, A, F8.4, A, F8.4, A)
130   Format (1X, 2A, /, 1X, A)
140   Format (1X, A, /, 1X, A, /, 1X, A, 1P, E8.1)
150   Format (1X, A, /, 1X, A, 1P, E8.1)
160   Format (1X, 2A, 1P, E8.1)
170   Format (1X, A, I4)
    End Program


\ number.f      - pictured number output words
\ ------------------------------------------------------------------------

  .( loading number.f ) cr

\ ------------------------------------------------------------------------

  0 var hld                 \ points to place to construct number

\ ------------------------------------------------------------------------
\ initiate pictured number construction

: <#            ( --- )
  pad !> hld ;              \ point hold at pad

\ ------------------------------------------------------------------------
\ store one digit/char of number, decrement pointer

: hold      ( c1 --- )
  decr> hld                 \ decrement pointer to pad area
  hld c! ;                  \ store char c1 at address pointed to by hld

\  -------------------------------------------------------------------------
\  hold a '-' if number is negative

: sign          ( n1 --- )
  0< not ?exit
  '-' hold ;

\ ------------------------------------------------------------------------
\ add one digit in current radix to number string

: #         ( d1 --- d2 )
  base mu/mod rot           \ divide number d1 by current radix.
  dup 9 > 7 and +           \ adjust remainder if above 9, add 7
  '0' + hold ;              \ convert to printable character and add it

\ -------------------------------------------------------------------------
\ convert rest of number n1 in current base

: #s            ( d1 --- 0 0 )
  begin
    #                       \ convert next digit
    2dup or 0=              \ anything left to convert ?
  until ;                   \ if so, keep going

\ ------------------------------------------------------------------------
\ complete conversion of number to a string

: #>        ( d1 --- a1 n1 )
  2drop                     \ clean up
  hld pad over - ;          \ return anddress and length of new string

\ ------------------------------------------------------------------------
\ convert a double number to string

: (d.)      ( d1 --- a1 n1 )
  tuck dabs                 \ retain sign, make positive
  <# #s rot sign #> ;       \ convert number, add possible neg sign

\ ------------------------------------------------------------------------
\ display string representation of double number d1 in current radix

: d.        ( d1 --- )
  (d.) type space ;

\ ------------------------------------------------------------------------
\ display right justified number

: d.r       ( d1 n1 --- )
  >r (d.)
  r> over - spaces
  type ;

\ ------------------------------------------------------------------------
\ convert a single to a double ( these dot words work on doubles only )

: .         ( n1 --- )
  s>d d. ;

\ ------------------------------------------------------------------------
\ display right justified single

: .r        ( n1 n2 --- )
  >r s>d r>
  d.r ;

\ ------------------------------------------------------------------------
\ display unsigned single

: u.        ( u1 --- )
  0 d. ;

\ ------------------------------------------------------------------------
\ display right justified unsigned single

: u.r       ( u1 --- )
  0 swap d.r ;

\ ------------------------------------------------------------------------

: radix         ( n1 --- )  !> base ;

\ ------------------------------------------------------------------------
\ forth can use almost any damned base it wants to

: hex           ( --- )  16 radix ;
: decimal       ( --- )  10 radix ;
: binary        ( --- )   2 radix ;
: octal         ( --- )   8 radix ;

\ ========================================================================


! Mikayla Webber
! 4670 Numerical Analysis
! Homework IVP Due 12.6.17

program predictorcorrector
  implicit none
  integer :: i, neq, nsteps
  double precision , allocatable, dimension(:) :: yin, yout, t, u, f
  double precision , allocatable, dimension(: , :) :: archive
  double precision :: dt, a, b, x, y, xactual, yactual
  double precision , allocatable, dimension(:) :: fi, fim1, fim2, fim3, fim4, fip1

  neq = 1
  nsteps = 100

  allocate( yin(neq), yout(neq), u(neq), t(0:nsteps), f(neq), archive(neq, 0:nsteps))
  allocate(fi(neq), fim1(neq), fim2(neq), fim3(neq), fim4(neq), fip1(neq))

  a = 1.0d0
  b = 2.0d0
  dt = (b-a) / dble(nsteps)

  do i = 0, nsteps
      t(i) = a + dble(i)*dt
  end do

  archive(:,0) = (/ 1.0d0, 0.0d0, 0.0d0, 1.0d0 /)
  call abinitializer(neq, nsteps, t, archive)

  do i = 4, nsteps - 1
    call computef(neq, t(i), archive(:,i), fi)
    call computef(neq, t(i-1), archive(:,i-1), fim1)
    call computef(neq, t(i-2), archive(:,i-2), fim2)
    call computef(neq, t(i-3), archive(:,i-3), fim3)
    call computef(neq, t(i-4), archive(:,i-4), fim4)
    u = archive(:, i) + dt / 720.0d0 * (1901.0d0 * fi -2774.0d0*fim1 + 2616.0d0* fim2 - 1274.0d0*fim3 + 251.0d0 * fim4)
    call computef(neq, t(i+1), u, fip1)
    archive(:, i+1) = archive(:,i) + dt / 720.0d0 * (251.0d0 * fip1 + 646.0d0*fi - 264.0d0*fim1 + 106.0d0*fim2 - 19.0d0 * fim3)
   end do

   print*, 'writing "aopc"'
   open(unit=8, file ='aopc', status='replace')

   do i = 0, nsteps
     write(8,*) t(i), archive(1,i)
   end do

   close(8)

   print*, 'writing "aopcerror"'
   open(unit = 8, file = 'aopcerror', status = 'replace')

   do i = 0, nsteps
     x = archive(1, i)
     y = archive(2, i)
     xactual = cos(t(i))
     yactual = t(i) / ( 1 + log(t(i)))
     write(8,*) i, SQRT((x - xactual)**2 + (y - yactual)**2)
   end do

   deallocate(yin, yout, u, archive, t, f)
   deallocate(fi, fim1, fim2, fim3, fim4, fip1)

   stop
 end program predictorcorrector

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

subroutine abinitializer(neq, nsteps, t, archive)
  implicit none
  integer :: nsteps
  integer, intent(in) :: neq
  double precision, intent(in) :: t(0:nsteps)
  double precision :: yout(neq), tin, tout, yin(neq), archive(neq, 0:nsteps)

  tin = t(0)
  yin = archive(:,0)
  tout = t(1)
  call extrapolate(neq, tin, tout, yin, yout)
  archive(:,1) = yout

  tin = t(1)
  yin = archive(:,1)
  tout = t(2)
  call extrapolate(neq, tin, tout, yin, yout)
  archive(:,2) = yout

  tin = t(2)
  yin = archive(:,2)
  tout = t(3)
  call extrapolate(neq, tin, tout, yin, yout)
  archive(:,3) = yout

  tin = t(3)
  yin = archive(:,3)
  tout = t(4)
  call extrapolate(neq, tin, tout, yin, yout)
  archive(:,4) = yout

  return
end

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

subroutine extrapolate(neq, tin, tout, yin, yout)
  implicit none
  integer, intent(in) :: neq
  integer :: i, k, nrich, nsteps
  double precision :: yout(neq), bot
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision, allocatable, dimension(:,:,:) :: table

  nrich = 10
  nsteps = 1
  allocate(table(0:nrich,0:nrich,neq))

  do i = 0, nrich
    call euler(neq, tin, tout, nsteps, yin, yout)
    table(i,0,:) = yout
    nsteps = nsteps * 2
  end do

  do k = 1, nrich
    bot = 2.0d0**k - 1.0d0
    do i = k, nrich
      table(i,k,:) = table(i,k-1,:) + (table(i,k-1,:) - table(i-1,k-1,:)) / bot
    end do
  end do

  yout = table(nrich,nrich,:)

  return
end

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

subroutine euler(neq, tin, tout, nsteps, yin, yout)
  implicit none
  integer :: i
  integer, intent(in) :: neq, nsteps
  double precision, intent(in) :: tin, tout, yin(neq)
  double precision :: dt, f(neq), yout(neq)

  yout = yin
  dt = ((tout - tin) / dble(nsteps))

  do i = 0, nsteps - 1
    call computef(neq, tin + dble(i) * dt, yout, f)
    yout = (yout + dt * f)
  end do

  return
end

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

subroutine computef(neq, t, y, f)
  implicit none
  integer :: neq
  double precision :: f(neq)
  double precision, intent(in) :: t, y(neq)

  f(1) = (((1 + y(1)) / t) - (y(1) / t)**2)

  return
end


C/MEMBR ADD NAME=WASUM,SSI=0
c     Copyright INRIA
      double precision function wasum(n,xr,xi,incx)
c!but
c
c     cette fonction determine la addition des normes l1 des
c     composantes d'un vecteur complexe dont les parties reelles
c     sont rangees dans le vecteur double precision xr et les
c     parties imaginaires dans le vecteur double precision xi.
c
c!liste d'appel
c
c      double precision function wasum(n,xr,xi,incx)
c
c      n: entier, taille du vecteur traite
c
c      xr, xi: vecteurs double precision contenant,
c     respectivement,  les parties reelles et imaginaires du
c     vecteur traite.
c
c      incx: increment entre deux composantes consecutives des
c     vecteurs xr ou xi.
c
c!auteur
c
c     cleve moler.- mathlab.
c
c!
      double precision xr(*),xi(*),s
c     norm1(x)
      s = 0.0d+0
      if (n .le. 0) go to 20
      ix = 1
      do 10 i = 1, n
         s = s + abs(xr(ix)) + abs(xi(ix))
         ix = ix + incx
   10 continue
   20 wasum = s
      return
      end


program concatenate
implicit none
integer, parameter :: n1 = 2, n2 = 3
integer :: imat(n1,n2),ivec(n1),i
integer, allocatable :: jmat(:,:)
imat(1,:) = [10,11,12]
imat(2,:) = [20,21,22]
ivec = 10*imat(:,n2) ! [120,220]
jmat = reshape([imat,ivec,4,9],[n1,n2+2])
do i=1,size(jmat,1)
   print "(*(i5))",jmat(i,:)
end do
end program concatenate
! output:
!   10   11   12  120    4
!   20   21   22  220    9


        subroutine idd_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                         work,p,t,r,r2,r3,ind,indt)
c
c       routine idd_id2svd serves as a memory wrapper
c       for the present routine (please see routine idd_id2svd
c       for further documentation).
c
        implicit none
c
        character*1 jobz
        integer m,n,krank,list(n),ind(n),indt(m),iftranspose,
     1          lwork,ldu,ldvt,ldr,info,j,k,ier
        real*8 b(m,krank),proj(krank,n-krank),p(krank,n),
     1         r(krank,n),r2(krank,m),t(n,krank),r3(krank,krank),
     2         u(m,krank),v(n,krank),s(krank),work(25*krank**2)
c
c
c
        ier = 0
c
c
c
c       Construct the projection matrix p from the ID.
c
        call idd_reconint(n,list,krank,proj,p)
c
c
c
c       Compute a pivoted QR decomposition of b.
c
        call iddr_qrpiv(m,krank,b,krank,ind,r)
c
c
c       Extract r from the QR decomposition.
c
        call idd_rinqr(m,krank,b,krank,r)
c
c
c       Rearrange r according to ind.
c
        call idd_rearr(krank,ind,krank,krank,r)
c
c
c
c       Transpose p to obtain t.
c
        call idd_mattrans(krank,n,p,t)
c
c
c       Compute a pivoted QR decomposition of t.
c
        call iddr_qrpiv(n,krank,t,krank,indt,r2)
c
c
c       Extract r2 from the QR decomposition.
c
        call idd_rinqr(n,krank,t,krank,r2)
c
c
c       Rearrange r2 according to indt.
c
        call idd_rearr(krank,indt,krank,krank,r2)
c
c
c
c       Multiply r and r2^T to obtain r3.
c
        call idd_matmultt(krank,krank,r,krank,r2,r3)
c
c
c
c       Use LAPACK to SVD r3.
c
        jobz = 'S'
        ldr = krank
        lwork = 25*krank**2-krank**2-4*krank
        ldu = krank
        ldvt = krank
c
        call dgesdd(jobz,krank,krank,r3,ldr,s,work,ldu,r,ldvt,
     1              work(krank**2+4*krank+1),lwork,
     2              work(krank**2+1),info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c
c       Multiply the u from r3 from the left by the q from b
c       to obtain the u for a.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = work(j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        iftranspose = 0
        call idd_qmatmat(iftranspose,m,krank,b,krank,krank,u,r2)
c
c
c
c       Transpose r to obtain r2.
c
        call idd_mattrans(krank,krank,r,r2)
c
c
c       Multiply the v from r3 from the left by the q from p^T
c       to obtain the v for a.
c
        do k = 1,krank
c
          do j = 1,krank
            v(j,k) = r2(j,k)
          enddo ! j
c
          do j = krank+1,n
            v(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        iftranspose = 0
        call idd_qmatmat(iftranspose,n,krank,t,krank,krank,v,r2)
c
c
        return
        end
c
c
c
c


subroutine  DAYKM(thick)
  use simsphere_mod
  implicit none

! **  This routine computes eddy diffusivities as a function of height,
! **  friction velocity and Monin Obukhov length for all the relevant
! **  levels in the mixing layer at each time step during the day; using
! **  the method of O'Brien.  Used in MOMDAY.

  real :: KTOP , KMA , KMAPRI , KMW(50)
  real, intent(inout) :: THICK
  real :: RATIO, SIGN

  integer :: I, J, L, M

!      INCLUDE 'modvars.h'

!  COMMON /MXDLYR/ THICK

  THICK = HGT - ZA

! **  If there is no mixing layer skip this routine.

  if ( .not. eq(thick,0.0) ) then

! **  Define or calc eddy diff's (K's) at the top of the surface layer
! **  using the standard flux profile law.  Calculate the derivative
! **  of KMA and define K at the top of the mixing layer to be zero.

    !KMA = KARMAN * USTAR * ZA * ( 1.0 - ( 15.0 * ZA / MOL )**0.25)
    ! This matches the original f77 code:
    KMA = KARMAN * USTAR * ZA * ( 1.0 - ( 15.0 * ZA / MOL ) )**0.25
    KM(1) = KMA
    KMW(1) = KMA
    KMAPRI = KMA * (1.0 / ZA - ( 15.0 / MOL ) / (1.0 - 15.0 * ZA / MOL))
    KTOP = 0.0

! **  Calc heights between the 250 metre intervals (ZI system) as passed
! **  from SPLINE, and call ZK system (Interval 50,175,425 etc).

    M = NTRP + 1
    do I = 2 , M
      ZK(I) = ZI(I) - 0.5 * DELTAZ
    end do
    ZK(1) = ZI(1)

! **  Calc the Eddy Diffusivities for momentum & water up to the top of
! **  the mixing layer using the O'Brien function.  If NRTP goes above
! **  HGT fill with zeros.

    do L = 2 , NTRP
      IF ( ZK(L) < HGT ) THEN
        KM(L) = KTOP + ( ( ZK(L) - HGT)**2 / THICK**2 ) * ( KMA - KTOP +  &
                ( ZK(L) - ZA ) * ( KMAPRI + 2 * ( KMA - KTOP ) / THICK ) )
        KMW(L) = KTOP + ( ( ZI(L) - HGT )**2 / THICK**2 ) * ( KMA - KTOP  &
                 + ( ZI(L) - ZA ) * ( KMAPRI + 2 * ( KMA - KTOP ) / THICK ) )
      ELSE
        KM(L)  = 0
        KMW(L) = 0
      END IF
    end do

! **  Smooth K's as a weighted average.

    do J = 2 , NTRP
      KM(J) = ( KMW(J) + KM(J) + KMW(J-1 ) ) / 3
    end do

! **  No mixing layer exists.

  end if

! **  Format statements

  return
end


      subroutine evol_betakd(n_K,n_beta,np1_K,np1_beta,x,Nx,eta,ht,hx,mu
     &s,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 eta
      real*8 ht
      real*8 hx
      real*8 mus
      real*8 myzero
      real*8 n_K(Nx)
      real*8 n_beta(Nx)
      real*8 np1_K(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_beta(i) - 0.2D1 / (eta * ht + 0.2D1) * ht * ((-0.1D1 * n_
     #beta(i) + np1_beta(i)) / ht - 0.2500000000000000D0 * mus * (-0.1D1
     # * np1_K(i - 1) + np1_K(i + 1)) / hx + 0.5000000000000000D0 * eta
     #* np1_beta(i) - 0.2500000000000000D0 * mus * (-0.1D1 * n_K(i - 1)
     #+ n_K(i + 1)) / hx + 0.5000000000000000D0 * eta * n_beta(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      END


MODULE LogBeta
! Log of the beta function
! Includes log of the gamma function

IMPLICIT NONE

CONTAINS

FUNCTION betaln(a0, b0) RESULT(fn_val)
!-----------------------------------------------------------------------
!     EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION
!-----------------------------------------------------------------------
!     E = 0.5*LN(2*PI)
!--------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a0, b0
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER  :: e = .918938533204673_dp
REAL (dp)             :: a, b, c, h, u, v, w, z
INTEGER               :: i, n
REAL (dp), PARAMETER  :: half = 0.5_dp, one = 1.0_dp, two = 2.0_dp,  &
                         eight = 8.0_dp
!--------------------------
a = MIN(a0, b0)
b = MAX(a0, b0)
IF (a < eight) THEN
  IF (a < one) THEN
!-----------------------------------------------------------------------
!                   PROCEDURE WHEN A < 1
!-----------------------------------------------------------------------
    IF (b < eight) THEN
      fn_val = gamln(a) + (gamln(b) - gamln(a+b))
      RETURN
    END IF
    fn_val = gamln(a) + algdiv(a,b)
    RETURN
  END IF
!-----------------------------------------------------------------------
!                PROCEDURE WHEN 1 <= A < 8
!-----------------------------------------------------------------------
  IF (a <= two) THEN
    IF (b <= two) THEN
      fn_val = gamln(a) + gamln(b) - gsumln(a,b)
      RETURN
    END IF
    w = 0.0
    IF (b < eight) GO TO 20
    fn_val = gamln(a) + algdiv(a,b)
    RETURN
  END IF

!                REDUCTION OF A WHEN B <= 1000

  IF (b > 1000.0_dp) GO TO 40
  n = a - one
  w = one
  DO i = 1, n
    a = a - one
    h = a / b
    w = w * (h/(one + h))
  END DO
  w = LOG(w)
  IF (b >= eight) THEN
    fn_val = w + gamln(a) + algdiv(a,b)
    RETURN
  END IF

!                 REDUCTION OF B WHEN B < 8

  20 n = b - one
  z = one
  DO i = 1, n
    b = b - one
    z = z * (b/(a+b))
  END DO
  fn_val = w + LOG(z) + (gamln(a) + (gamln(b) - gsumln(a,b)))
  RETURN

!                REDUCTION OF A WHEN B > 1000

  40 n = a - one
  w = one
  DO i = 1, n
    a = a - one
    w = w * (a/(one+a/b))
  END DO
  fn_val = (LOG(w) - n*LOG(b)) + (gamln(a) + algdiv(a,b))
  RETURN
END IF
!-----------------------------------------------------------------------
!                   PROCEDURE WHEN A >= 8
!-----------------------------------------------------------------------
w = bcorr(a,b)
h = a / b
c = h / (one + h)
u = -(a-half) * LOG(c)
v = b * alnrel(h)
IF (u > v) THEN
  fn_val = (((-half*LOG(b) + e) + w) - v) - u
  RETURN
END IF
fn_val = (((-half*LOG(b) + e) + w) - u) - v
RETURN
END FUNCTION betaln

FUNCTION gamln(a) RESULT(fn_val)
!-----------------------------------------------------------------------
!            EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A
!-----------------------------------------------------------------------
!     WRITTEN BY ALFRED H. MORRIS
!          NAVAL SURFACE WARFARE CENTER
!          DAHLGREN, VIRGINIA
!--------------------------
!     D = 0.5*(LN(2*PI) - 1)
!--------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER :: d = 0.418938533204673_dp, c0 = 0.833333333333333D-01,   &
              c1 = -0.277777777760991D-02, c2 = 0.793650666825390D-03,   &
              c3 = -0.595202931351870D-03, c4 = 0.837308034031215D-03,   &
              c5 = -0.165322962780713D-02
REAL (dp)  :: t, w
INTEGER    :: i, n
!-----------------------------------------------------------------------
IF (a <= 0.8_dp) THEN
  fn_val = gamln1(a) - LOG(a)
  RETURN
END IF
IF (a <= 2.25_dp) THEN
  t = (a-0.5_dp) - 0.5_dp
  fn_val = gamln1(t)
  RETURN
END IF

IF (a < 10.0_dp) THEN
  n = a - 1.25_dp
  t = a
  w = 1.0_dp
  DO i = 1, n
    t = t - 1.0_dp
    w = t * w
  END DO
  fn_val = gamln1(t-1.0) + LOG(w)
  RETURN
END IF

t = (1.0/a) ** 2
w = (((((c5*t + c4)*t + c3)*t + c2)*t + c1)*t + c0) / a
fn_val = (d+w) + (a-0.5) * (LOG(a)-1.0)
RETURN
END FUNCTION gamln

FUNCTION algdiv(a, b) RESULT(fn_val)
!-----------------------------------------------------------------------

!     COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B >= 8

!                         --------

!     IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
!     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).

!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a, b
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER  :: c0 = .833333333333333D-01, c1 = -.277777777760991D-02,  &
                    c2 = .793650666825390D-03, c3 = -.595202931351870D-03,  &
                    c4 = .837308034031215D-03, c5 = -.165322962780713D-02
REAL (dp) :: c, d, h, s3, s5, s7, s9, s11, t, u, v, w, x, x2
!------------------------
IF (a > b) THEN
  h = b / a
  c = 1.0 / (1.0_dp + h)
  x = h / (1.0_dp + h)
  d = a + (b - 0.5_dp)
ELSE
  h = a / b
  c = h / (1.0_dp + h)
  x = 1.0 / (1.0_dp + h)
  d = b + (a - 0.5_dp)
END IF

!                SET SN = (1 - X**N)/(1 - X)

x2 = x * x
s3 = 1.0 + (x + x2)
s5 = 1.0 + (x + x2*s3)
s7 = 1.0 + (x + x2*s5)
s9 = 1.0 + (x + x2*s7)
s11 = 1.0 + (x + x2*s9)

!                SET W = DEL(B) - DEL(A + B)

t = (1.0_dp/b) ** 2
w = ((((c5*s11*t + c4*s9)*t + c3*s7)*t + c2*s5)*t + c1*s3) * t + c0
w = w * (c/b)

!                    COMBINE THE RESULTS

u = d * alnrel(a/b)
v = a * (LOG(b) - 1.0_dp)
IF (u > v) THEN
  fn_val = (w-v) - u
  RETURN
END IF
fn_val = (w-u) - v
RETURN
END FUNCTION algdiv

FUNCTION gsumln(a, b) RESULT(fn_val)
!-----------------------------------------------------------------------
!          EVALUATION OF THE FUNCTION LN(GAMMA(A + B))
!          FOR 1 <= A <= 2  AND  1 <= B <= 2
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a, b
REAL (dp)             :: fn_val

! Local variables
REAL (dp) :: x

x = a + b - 2.0_dp
IF (x <= 0.25_dp) THEN
  fn_val = gamln1(1.0_dp + x)
  RETURN
END IF
IF (x <= 1.25_dp) THEN
  fn_val = gamln1(x) + alnrel(x)
  RETURN
END IF
fn_val = gamln1(x - 1.0_dp) + LOG(x*(1.0_dp + x))
RETURN
END FUNCTION gsumln

FUNCTION bcorr(a0, b0) RESULT(fn_val)
!-----------------------------------------------------------------------

!     EVALUATION OF  DEL(A0) + DEL(B0) - DEL(A0 + B0)  WHERE
!     LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A).
!     IT IS ASSUMED THAT A0 >= 8 AND B0 >= 8.

!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a0, b0
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER :: c0 = .833333333333333D-01, c1 = -.277777777760991D-02,  &
                   c2 = .793650666825390D-03, c3 = -.595202931351870D-03,  &
                   c4 = .837308034031215D-03, c5 = -.165322962780713D-02
REAL (dp) :: a, b, c, h, s3, s5, s7, s9, s11, t, w, x, x2
!------------------------
a = MIN(a0,b0)
b = MAX(a0,b0)

h = a / b
c = h / (1.0_dp + h)
x = 1.0 / (1.0_dp + h)
x2 = x * x

!                SET SN = (1 - X**N)/(1 - X)

s3 = 1.0 + (x + x2)
s5 = 1.0 + (x + x2*s3)
s7 = 1.0 + (x + x2*s5)
s9 = 1.0 + (x + x2*s7)
s11 = 1.0 + (x + x2*s9)

!                SET W = DEL(B) - DEL(A + B)

t = (1.0_dp/b) ** 2
w = ((((c5*s11*t + c4*s9)*t + c3*s7)*t + c2*s5)*t + c1*s3) * t + c0
w = w * (c/b)

!                   COMPUTE  DEL(A) + W

t = (1.0_dp/a) ** 2
fn_val = (((((c5*t + c4)*t + c3)*t + c2)*t + c1)*t + c0) / a + w
RETURN
END FUNCTION bcorr

FUNCTION alnrel(a) RESULT(fn_val)
!-----------------------------------------------------------------------
!            EVALUATION OF THE FUNCTION LN(1 + A)
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER  :: p1 = -.129418923021993D+01, p2 = .405303492862024D+00,  &
        p3 = -.178874546012214D-01, q1 = -.162752256355323D+01,   &
        q2 =  .747811014037616D+00, q3 = -.845104217945565D-01,  &
        zero = 0.0_dp, half = 0.5_dp, one = 1.0_dp, two = 2.0_dp
REAL (dp) :: t, t2, w, x
!--------------------------
IF (ABS(a) <= 0.375_dp) THEN
  t = a / (a + two)
  t2 = t * t
  w = (((p3*t2 + p2)*t2 + p1)*t2 + one) / (((q3*t2 + q2)*t2 + q1)*t2 + one)
  fn_val = two * t * w
  RETURN
END IF

x = one + a
IF (a < zero) x = (a + half) + half
fn_val = LOG(x)
RETURN
END FUNCTION alnrel

FUNCTION gamln1(a) RESULT(fn_val)
!-----------------------------------------------------------------------
!     EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 <= A <= 1.25
!-----------------------------------------------------------------------
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)

REAL (dp), INTENT(IN) :: a
REAL (dp)             :: fn_val

! Local variables
REAL (dp), PARAMETER  :: p0 = .577215664901533D+00, p1 = .844203922187225D+00,  &
        p2 = -.168860593646662D+00, p3 = -.780427615533591D+00,   &
        p4 = -.402055799310489D+00, p5 = -.673562214325671D-01,   &
        p6 = -.271935708322958D-02, q1 = .288743195473681D+01,   &
        q2  = .312755088914843D+01, q3 = .156875193295039D+01,   &
        q4  = .361951990101499D+00, q5 = .325038868253937D-01,   &
        q6  = .667465618796164D-03, r0 = .422784335098467D+00,   &
        r1  = .848044614534529D+00, r2 = .565221050691933D+00,   &
        r3  = .156513060486551D+00, r4 = .170502484022650D-01,   &
        r5  = .497958207639485D-03, s1 = .124313399877507D+01,   &
        s2  = .548042109832463D+00, s3 = .101552187439830D+00,   &
        s4  = .713309612391000D-02, s5 = .116165475989616D-03
REAL (dp)  :: w, x
!----------------------
IF (a < 0.6_dp) THEN
  w = ((((((p6*a + p5)*a + p4)*a + p3)*a + p2)*a + p1)*a + p0) /   &
      ((((((q6*a + q5)*a + q4)*a + q3)*a + q2)*a + q1)*a + 1.0)
  fn_val = -a * w
  RETURN
END IF

x = (a - 0.5_dp) - 0.5_dp
w = (((((r5*x + r4)*x + r3)*x + r2)*x + r1)*x + r0) / (((((s5*x + s4)*x +  &
    s3)*x + s2)*x + s1)*x + 1.0_dp)
fn_val = x * w
RETURN
END FUNCTION gamln1

END MODULE LogBeta

FUNCTION betain(x, p, q, beta) RESULT(fn_val)

!   Algorithm AS 63  Appl. Statist. (1973), vol.22, no.3

!   Computes incomplete beta function ratio for arguments
!   x between zero and one, p and q positive.
!   Log of complete beta function, beta, is assumed to be known

! ELF90-compatible version by Alan Miller
! N.B. Argument IFAULT has been removed

! Latest revision - 5 July 2003

USE LogBeta
IMPLICIT NONE
INTEGER, PARAMETER    :: dp = SELECTED_REAL_KIND(15, 100)
REAL (dp), INTENT(IN) :: x, p, q, beta
REAL (dp)             :: fn_val

! Local variables
LOGICAL               :: indx
INTEGER               :: ns
REAL (dp)             :: psq, cx, xx, pp, qq, term, ai, rx, temp

!   Define accuracy and initialise

REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp, acu = 1.0E-14_dp

fn_val = x

!   Test for admissibility of arguments

IF(p <= zero .OR. q <= zero) THEN
  WRITE(*, *) 'AS63: Either p or q <= 0'
  RETURN
END IF
IF(x < zero .OR. x > one) THEN
  WRITE(*, *) 'AS63: Argument x outside range (0, 1)'
  RETURN
END IF
IF(x == zero .OR. x == one) RETURN

!   Change tail if necessary and determine s

psq = p + q
cx = one - x
IF(p < psq*x) THEN
  xx = cx
  cx = x
  pp = q
  qq = p
  indx = .true.
ELSE
  xx = x
  pp = p
  qq = q
  indx = .false.
END IF
term = one
ai = one
fn_val = one
ns = qq + cx*psq

!     Use Soper's reduction formulae.

rx = xx/cx
3 temp = qq - ai
IF(ns == 0) rx = xx
4 term = term*temp*rx/(pp+ai)
fn_val = fn_val + term
temp = ABS(term)
IF(temp <= acu .AND. temp <= acu*fn_val) GO TO 5
ai = ai + one
ns = ns - 1
IF(ns >= 0) GO TO 3
temp = psq
psq = psq+one
GO TO 4

!     Calculate result

5 fn_val = fn_val*EXP(pp*LOG(xx) + (qq-one)*LOG(cx) - beta)/pp
IF(indx) fn_val = one - fn_val

RETURN
END FUNCTION betain


*> \brief \b DLATSQR
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
*                           LWORK, INFO)
*
*       .. Scalar Arguments ..
*       INTEGER           INFO, LDA, M, N, MB, NB, LDT, LWORK
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION  A( LDA, * ), T( LDT, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLATSQR computes a blocked Tall-Skinny QR factorization of
*> an M-by-N matrix A, where M >= N:
*> A = Q * R .
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*>          MB is INTEGER
*>          The row block size to be used in the blocked QR.
*>          MB > N.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          The column block size to be used in the blocked QR.
*>          N >= NB >= 1.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the elements on and above the diagonal
*>          of the array contain the N-by-N upper triangular matrix R;
*>          the elements below the diagonal represent Q by the columns
*>          of blocked V (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is DOUBLE PRECISION array,
*>          dimension (LDT, N * Number_of_row_blocks)
*>          where Number_of_row_blocks = CEIL((M-N)/(MB-N))
*>          The blocked upper triangular block reflectors stored in compact form
*>          as a sequence of upper triangular blocks.
*>          See Further Details below.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= NB.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>         (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          The dimension of the array WORK.  LWORK >= NB*N.
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
*> representing Q as a product of other orthogonal matrices
*>   Q = Q(1) * Q(2) * . . . * Q(k)
*> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
*>   Q(1) zeros out the subdiagonal entries of rows 1:MB of A
*>   Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
*>   Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
*>   . . .
*>
*> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
*> stored under the diagonal of rows 1:MB of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,1:N).
*> For more information see Further Details in GEQRT.
*>
*> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
*> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
*> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
*> The last Q(k) may use fewer rows.
*> For more information see Further Details in TPQRT.
*>
*> For more details of the overall algorithm, see the description of
*> Sequential TSQR in Section 2.2 of [1].
*>
*> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
*>     J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
*>     SIAM J. Sci. Comput, vol. 34, no. 1, 2012
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK,
     $                    LWORK, INFO)
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. --
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER           INFO, LDA, M, N, MB, NB, LDT, LWORK
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), WORK( * ), T(LDT, *)
*     ..
*
*  =====================================================================
*
*     ..
*     .. Local Scalars ..
      LOGICAL    LQUERY
      INTEGER    I, II, KK, CTR
*     ..
*     .. EXTERNAL FUNCTIONS ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. EXTERNAL SUBROUTINES ..
      EXTERNAL           DGEQRT, DTPQRT, XERBLA
*     .. INTRINSIC FUNCTIONS ..
      INTRINSIC          MAX, MIN, MOD
*     ..
*     .. EXECUTABLE STATEMENTS ..
*
*     TEST THE INPUT ARGUMENTS
*
      INFO = 0
*
      LQUERY = ( LWORK.EQ.-1 )
*
      IF( M.LT.0 ) THEN
        INFO = -1
      ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
        INFO = -2
      ELSE IF( MB.LE.N ) THEN
        INFO = -3
      ELSE IF( NB.LT.1 .OR. ( NB.GT.N .AND. N.GT.0 )) THEN
        INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
        INFO = -5
      ELSE IF( LDT.LT.NB ) THEN
        INFO = -8
      ELSE IF( LWORK.LT.(N*NB) .AND. (.NOT.LQUERY) ) THEN
        INFO = -10
      END IF
      IF( INFO.EQ.0)  THEN
        WORK(1) = NB*N
      END IF
      IF( INFO.NE.0 ) THEN
        CALL XERBLA( 'DLATSQR', -INFO )
        RETURN
      ELSE IF (LQUERY) THEN
       RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN(M,N).EQ.0 ) THEN
          RETURN
      END IF
*
*     The QR Decomposition
*
       IF ((MB.LE.N).OR.(MB.GE.M)) THEN
         CALL DGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO)
         RETURN
       END IF
*
       KK = MOD((M-N),(MB-N))
       II=M-KK+1
*
*      Compute the QR factorization of the first block A(1:MB,1:N)
*
       CALL DGEQRT( MB, N, NB, A(1,1), LDA, T, LDT, WORK, INFO )
*
       CTR = 1
       DO I = MB+1, II-MB+N ,  (MB-N)
*
*      Compute the QR factorization of the current block A(I:I+MB-N,1:N)
*
         CALL DTPQRT( MB-N, N, 0, NB, A(1,1), LDA, A( I, 1 ), LDA,
     $                 T(1, CTR * N + 1),
     $                  LDT, WORK, INFO )
         CTR = CTR + 1
       END DO
*
*      Compute the QR factorization of the last block A(II:M,1:N)
*
       IF (II.LE.M) THEN
         CALL DTPQRT( KK, N, 0, NB, A(1,1), LDA, A( II, 1 ), LDA,
     $                 T(1, CTR * N + 1), LDT,
     $                  WORK, INFO )
       END IF
*
      WORK( 1 ) = N*NB
      RETURN
*
*     End of DLATSQR
*
      END


	SUBROUTINE DSPLIN ( itype, np, xpt, ypt, dens,
     +			    nout, xcv, ycv, iret )
C************************************************************************
C* DSPLIN								*
C*									*
C* This subroutine performs a cubic spline fit to NP data points using	*
C* relaxed boundary conditions.						*
C*									*
C* DSPLIN ( ITYPE, NP, XPT, YPT, DENS, NOUT, XCV, YCV, IRET )		*
C*									*
C* Input parameters:							*
C*	ITYPE		INTEGER		Type of end points		*
C*					  1 = relaxed			*
C*					  2 = cyclic			*
C*	NP		INTEGER		Number of input points		*
C*	XPT (NP)	REAL		X input coordinates		*
C*	YPT (NP)	REAL		Y input coordinates		*
C*	DENS		REAL		Density of intermediate points	*
C*									*
C* Output parameters:							*
C*	NOUT		INTEGER		Number of output points		*
C*	XCV (NOUT)	REAL		X evaluated coordinates		*
C*	YCV (NOUT)	REAL		Y evaluated coordinates		*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* S. Jacobs/NCEP	 2/98						*
C* S. Jacobs/NCEP	 4/98	Removed call to DCGAUS for cyclic end pt*
C* I. Durham/GSC	 4/98	Added routine to eliminate double points*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERROR.PRM'
C*
	REAL		xpt (*), ypt (*), xcv (*), ycv (*)
C*
	INTEGER		npt (LLMXPT)
	REAL		amtrx (LLMXPT,3), coeff (LLMXPT,2),
     +		 	chord (LLMXPT), xtng (LLMXPT), ytng (LLMXPT),
     +                  xtmp(LLMXPT), ytmp(LLMXPT)
C------------------------------------------------------------------------
	iret = 0
C
C*	Check for identical points and eliminate
C
	xtmp(1) = xpt(1)
	ytmp(1) = ypt(1)
	i = 2
	k = 2
	ntmp = np
	DO WHILE ( k .le. np )
	   IF ( ( xpt(i) .eq. xpt(i-1) ) .and.
     +          ( ypt(i) .eq. ypt(i-1) ) ) THEN
	      xtmp(k) = xpt(i+1)
	      ytmp(k) = ypt(i+1)
	      i   = i + 2
	      ntmp = ntmp - 1
	   ELSE
	      xtmp(k) = xpt(i)
	      ytmp(k) = ypt(i)
	      i = i + 1
	   END IF
	   k = k + 1
	END DO
C
C*	Zero fill the working matrices.
C
	DO  i = 1, LLMXPT
	    DO  j = 1, 2
		coeff (i,j) = 0.0
	    END DO
	    DO  j = 1, 3
		amtrx (i,j) = 0.0
	    END DO
	    chord (i) = 0.0
	END DO
C
C*	If the requested end point type is cyclic or the end points
C*	are the same, set the end point type to cyclic. Otherwise,
C*	set the end point type to relaxed.
C
C*	Commented out checks for cyclic end points. This needs to be
C*	fixed later.
C
C--	IF ( ( itype .eq. 2 ) .or.
C--     +     ( ( xtmp(1) .eq. xtmp(ntmp) ) .and.
C--     +       ( ytmp(1) .eq. ytmp(ntmp) ) ) ) THEN
C--	   jtype = 2
C--	ELSE
	   jtype = 1
C--	END IF
C
C*	Fill the working matrices with the coefficient values.
C
	CALL DMATRX ( jtype, ntmp, xtmp, ytmp, dens, amtrx, coeff,
     +		      chord, npt, nout, iret )
	IF  ( iret .ne. 0 )  RETURN
C
C*	Compute the smooth curve.
C
C*	Commented out checks for cyclic end points. This needs to be
C*	fixed later.
C
C--	IF  ( jtype .eq. 2 )  THEN
C
C*	    Use cyclic conditions for the end points.
C
C--	    CALL DCGAUS ( ntmp, amtrx, coeff, xtng, ytng, ier )
C--	  ELSE
C
C*	    Use relaxed conditions for the end points.
C
	    CALL DGAUSS ( ntmp, amtrx, coeff, xtng, ytng, ier )
C--	END IF
C
C*	Compute the points for the smooth curve.
C
	CALL DESPLN ( ntmp, xtmp, ytmp, chord, xtng, ytng, npt,
     +		      xcv, ycv, ier )
C*
	RETURN
	END


        subroutine projectMain(iteration, method, nx,ny)

c        parameter (nx=25,ny=25)
        integer iteration, method, nx,ny, ierror
        real*8 beta,err,eps,w,yl,xl,dx,dy
        real*8 tnew(nx,ny),told(nx,ny),wbeta,betaw
        real*8 tn(nx,ny),tn1(nx,ny),tn12(nx,ny)

        xl=1.0d+00
        yl=0.75d+00
        dx=xl/dfloat(nx-1)
        dy=yl/dfloat(ny-1)
        beta=(dx*dx)/(dy*dy)

        w=1.0d+00

c        do 103 lll=1,11

            w=w+(0.1d+00 *iteration)
            print*, 'Starting  [method,w] = ' , method, w

            wbeta=w/(2.0d+00*(beta+1.0d+00))
            betaw=2.0d+00*(1.0d+00+beta)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C      Method = 1 Jacobi Point                                         C
C             = 2 Gauss Point                                          C
C             = 3 Gauss Line                                           C
C             = 4 Jacobi Line                                          C
C             = 5 Gauss Line  (ADI)                                    C
C             = 6 Jacobi Line (ADI)                                    C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c           do method=1,6
c The method is passed as a parameter

               eps=1.d-14
               err=0.0d+00

c               print*, "Method Number ", method

               if (method.gt.4) then
                   do j=2,ny-1
                       do i=2,nx-1
                           tn1(i,j)=0.0d+00
                           tn(i,j)=0.0d+00
                           tn12(i,j)=0.0d+00
                       enddo
                   enddo

                   do j=1,ny
                       tn(nx,j)=1.0d+00
                       tn12(nx,j)=1.0d+00
                       tn1(nx,j)=1.0d+00
                       tn(1,j)=1.0d+00
                       tn12(1,j)=1.0d+00
                       tn1(1,j)=1.0d+00
                   enddo

                   do i=1,nx
                       tn(i,1)=1.0d+00
                       tn12(i,1)=1.0d+00
                       tn1(i,1)=1.0d+00
                       tn(i,ny)=3.0d+00
                       tn12(i,ny)=3.0d+00
                       tn1(i,ny)=3.0d+00
                   enddo

                   goto 111
               endif
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
C the else part of the if statement
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
               do j=2,ny-1
                   do i=2,nx-1
                       told(i,j)=0.0d+00
                       tnew(i,j)=0.0d+00
                   enddo
               enddo

               do j=1,ny
                   told(nx,j)=1.0d+00
                   tnew(nx,j)=1.0d+00
                   told(1,j)=1.0d+00
                   tnew(1,j)=1.0d+00
               enddo

               do i=1,nx
                   told(i,1)=1.0d+00
                   tnew(i,1)=1.0d+00
                   told(i,ny)=3.0d+00
                   tnew(i,ny)=3.0d+00
               enddo

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
C end the if statement on label 111
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCc
 111  continue

       if (method.eq.1) call JPoint   (nx,ny,beta,wbeta,err,eps,w,dx,dy,
     c                                   tnew,told,iter)
       if (method.eq.2) call GSPoint  (nx,ny,beta,wbeta,err,eps,w,dx,dy,
     c                                   tnew,told,iter)
       if (method.eq.3) call GSLine   (nx,ny,beta,wbeta,err,eps,w,dx,dy,
     c                                   tnew,told,iter)
       if (method.eq.4) call JLine    (nx,ny,beta,wbeta,err,eps,w,dx,dy,
     c                                   tnew,told,iter)
       if (method.eq.5) call GSLineADI(nx,ny,betaw,beta,err,eps,w,dx,dy,
     c                                   tn,tn1,tn12,iter)
       if (method.eq.6) call JLineADI (nx,ny,betaw,beta,err,eps,w,dx,dy,
     c                                  tn,tn1,tn12,iter)

      call tecplot(method,tnew,told,tn,tn12,tn1,dx,dy,nx,ny,iter)

C end the do loop started on line 33
c       enddo

C end the do loop started on line 17
c 103   continue
        return
       end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C      Creating Tecplot Files                                          C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       subroutine tecplot(method,tnew,told,tn,tn12,tn1,dx,dy,nx,ny,iter)
       integer nx,ny,method,iter
       real*8 tnew(nx,ny),told(nx,ny)
       real*8 tn(nx,ny),tn1(nx,ny),tn12(nx,ny),dxx,dyy,dx,dy
       character*16 filename1
       if (iter.ge.1000000) goto 1001
       print*, "Tecplot Files "

       if (method.eq.1) filename1='JP.plt'
       if (method.eq.2) filename1='GSP.plt'
       if (method.eq.3) filename1='GSL.plt'
       if (method.eq.4) filename1='JL.plt'
       if (method.eq.5) filename1='GSLADI.plt'
       if (method.eq.6) filename1='JLADI.plt'

       open(unit=1,file=filename1,status='unknown',access='append')

       if (method.lt.5) then
           write(1,*) 'VARAIBLES = "X","Y","tnew"'
           write(1,*) 'ZONE F=POINT, I=',nx,', J=',ny

            do j=1,ny
            dyy=0.0d+00
            dyy=dyy+dfloat(j-1)*dy
            do i=1,nx
            dxx=0.0d+00
            dxx=dxx+dfloat(i-1)*dx
            write(1,*)dxx,dyy,tnew(i,j)
            enddo
            enddo

           close(unit=1)
       else

           write(1,*) 'VARAIBLES = "X","Y","tn1"'
           write(1,*) 'ZONE F=POINT, I=',nx,', J=',ny

            do j=1,ny
            dyy=0.0d+00
            dyy=dyy+dfloat(j-1)*dy
            do i=1,nx
            dxx=0.0d+00
            dxx=dxx+dfloat(i-1)*dx
            write(1,*)dxx,dyy,tn1(i,j)
            enddo
            enddo

            close(unit=1)

        endif

       print*, "Ending Tecplot Files "
 1001  return
       end
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C      Jacobi Point Method
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

       subroutine JPoint(nx,ny,beta,wbeta,err,eps,w,dx,dy,tnew,told,
     c                                                          iter)

       integer nx,ny
       integer iter
       real*8 tnew(nx,ny),told(nx,ny)
       real*8 wbeta,beta,err,eps,w,dx,dy

       print*, "JPoint method"

        do iter=1,10000000
            if(Modulo(iter,1000000).eq.0) then
                print*, "JPoint iteration number = ", iter
            endif

            do j=2,ny-1
                do i=2,nx-1
                    tnew(i,j)=(1.0d+00-w)*told(i,j)+wbeta*
     c (told(i+1,j)+told(i-1,j)+beta*(told(i,j+1)+told(i,j-1)))

                enddo
            enddo

            do j=2,ny-1
                do i=2,nx-1
                    err=err+dabs(told(i,j)-tnew(i,j))
                enddo
            enddo

            err=err/dfloat(nx*ny)

            if (err.lt.eps) then
                print*,"eps and error ", eps,err
                goto 501
            endif

            do mm=2,ny-1
                do mn=2,nx-1
                    told(mn,mm)=tnew(mn,mm)
                enddo
            enddo

        enddo

 501   open(unit=2,file='iter.txt',status='unknown',access='append')

       write(2,*),'Jpoint    ','iter = ',iter,'omega =  ',w

       close(unit=2)

        return
        end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC    Gauss Seidel Point Method
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

       subroutine GSPoint(nx,ny,beta,wbeta,err,eps,w,dx,dy,tnew,told
     c                          ,iter)
       integer nx,ny
       real*8 told(nx,ny),tnew(nx,ny)
       real*8 wbeta,beta,err,eps,w,dx,dy

      print*, "Gauss Seidel Point method"

        do iter=1,1000000
            if(Modulo(iter,1000001).eq.0) then
                print*, "Gauss Seidel iteration number = ", iter
            endif

        do i=2,nx-1
        do j=2,ny-1
      tnew(i,j)=(1.0d+00-w)*told(i,j)+wbeta*
     c (told(i+1,j)+tnew(i-1,j)+beta*(told(i,j+1)+tnew(i,j-1)))
        enddo
        enddo
      do i=2,nx-1
      do j=2,ny-1
      err=err+dabs(told(i,j)-tnew(i,j))
      enddo
      enddo

      err=err/dfloat(nx*ny)

        if (err.lt.eps) then
        print*,eps,err
        goto 502
        endif

        do mm=2,nx-1
        do mn=2,ny-1
        told(mm,mn)=tnew(mm,mn)
        enddo
        enddo
        enddo

 502   open(unit=2,file='iter.txt',status='unknown',access='append')
       write(2,*),'GSpoint    ','iter = ',iter,'omega =  ',w
       close(unit=2)

        return
        end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC    THE GSL METHOD                                                CCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       subroutine GSLine (nx,ny,beta,wbeta,err,eps,w,dx,dy,tnew,told
     c                          ,iter)
       integer nx,ny,iter
       real*8 told(nx,ny),tnew(nx,ny)
       real*8 wbeta,beta,err,eps,w,dx,dy
        print*, "THE GSL METHOD  "

        do iter=1,1000000
        do j=2,ny-1
        do i=2,nx-1
        tnew(i,j)=(1.0d+00-w)*told(i,j)+wbeta*
     c   (tnew(i+1,j)+tnew(i-1,j)+beta*(told(i,j+1)+tnew(i,j-1)))
        enddo
        enddo

         do j=2,ny-1
         do i=2,nx-1
         err=err+dabs(told(i,j)-tnew(i,j))
         enddo
         enddo
         err=err/dfloat(nx*ny)

        if (err.lt.eps) then
        print*,eps,err
        goto 503
        endif

        do mm=2,ny-1
        do mn=2,nx-1
        told(mn,mm)=tnew(mn,mm)
        enddo
        enddo
        enddo

 503   open(unit=2,file='iter.txt',status='unknown',access='append')
       write(2,*),'GSLine    ','iter = ',iter,'omega =  ',w
       close(unit=2)

       return
       end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC    THE Jacobi Line METHOD                                        CCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       subroutine JLine (nx,ny,beta,wbeta,err,eps,w,dx,dy,tnew,told
     c                          ,iter)
       integer nx,ny,iter
       real*8 told(nx,ny),tnew(nx,ny)
       real*8 wbeta,beta,err,eps,w,dx,dy
         print*, "Jacobi Line METHOD"
        do iter=1,1000000
             if(Modulo(iter,1000000).eq.4) then
                print*, "Jacobi Line  iteration number = ", iter
            endif
        do j=2,ny-1
        do i=2,nx-1
        tnew(i,j)=(1.0d+00-w)*told(i,j)+wbeta*
     c    (tnew(i-1,j)+tnew(i+1,j)+beta*(told(i,j+1)+told(i,j-1)))
        enddo
        enddo

      do j=2,ny-1
      do i=2,nx-1
      err=err+dabs(told(i,j)-tnew(i,j))
      enddo
      enddo

      err=err/dfloat(nx*ny)

        if (err.lt.eps) then
        print*,eps,err
        goto 504
        endif

        do mm=2,ny-1
        do mn=2,nx-1
        told(mn,mm)=tnew(mn,mm)
        enddo
        enddo
        enddo

 504   open(unit=2,file='iter.txt',status='unknown',access='append')
       write(2,*),'JLine    ','iter = ',iter,'omega =  ',w
       close(unit=2)
       return
       end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCC    THE GSL METHOD  (ADI)                                         CCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCC First step
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine GSLineADI(nx,ny,betaw,beta,err,eps,w,dx,dy,tn,tn1,tn12
     c                          ,iter)

       integer nx,ny,iter
       real*8 tn12(nx,ny),a(nx),b(nx),tn(nx,ny)
       real*8 c(nx),d(nx),tn1(nx,ny)
       real*8 betaw,beta,err,eps,w,dx,dy
         print*, "GSL METHOD  (ADI)"

       do iter=1,1000000
       do j=2,ny-1
       do i=2,nx-1
       a(i)=-w
       b(i)=betaw
       c(i)=-w
       d(i)=betaw*tn(i,j)+w*(beta*(tn12(i,j-1)+tn(i,j+1))-betaw*tn(i,j))
       end do

        a(1)=0.0d+00
        a(nx-1)=0.0d+00

       d(2)=betaw*tn(2,j)+w*(beta*(tn12(2,j-1)+tn(2,j+1))
     c    -betaw*tn(2,j))+w*tn(1,j)

       d(nx-1)=betaw*tn(nx-1,j)+w*(beta*(tn12(nx-1,j-1)+
     c tn(nx-1,j+1))-betaw*tn(nx-1,j))+w*tn(nx,j)

        c(nx-1)=0.0d+00
        do k=3,nx-1
        b(k)=b(k)-(c(k-1)*a(k-1))/b(k-1)
        d(k)=d(k)-(d(k-1)*a(k-1))/b(k-1)
        end do
        tn12(nx-1,j)=d(nx-1)/b(nx-1)
        do m=nx-2,2,-1
        tn12(m,j)=(d(m)-c(m)*tn12(m+1,j))/b(m)
        end do
        end do
	do n=2,nx-1
        do nk=2,ny-1
        a(nk)=-w*beta
        b(nk)=betaw
        c(nk)=-w*beta

      d(nk)=betaw*tn12(n,nk)+w*(tn1(n-1,nk)+
     c tn12(n+1,nk)-betaw*tn12(n,nk))
        end do
        a(1)=0.0d+00
        a(nx-1)=0.0d+00

      d(2)=betaw*tn12(n,2)+w*(tn1(n-1,2)+tn12(n+1,2)
     c -betaw*tn12(n,2))+w*beta*tn12(n,1)
      d(nx-1)=betaw*tn12(n,ny-1)+w*(tn1(n-1,ny-1)+
     c tn12(n+1,ny-1)-betaw*tn12(n,ny-1))+w*beta*
     c tn12(n,ny)
        do ii=3,ny-1
        b(ii)=b(ii)-(c(ii-1)*a(ii-1))/b(ii-1)
        d(ii)=d(ii)-(d(ii-1)*a(ii-1))/b(ii-1)
        end do
	tn1(n,ny-1)=d(ny-1)/b(ny-1)
        do ii=ny-2,2,-1
	tn1(n,ii)=(d(ii)-c(ii)*tn1(n,ii+1))/b(ii)
        end do
        do ni=1,ny
        do ki=1,nx
        tn(ki,ni)=tn1(ki,ni)
        end do
        end do
        do kn=1,ny-1
        do km=1,nx
        err=err+dabs(tn12(km,kn)-tn1(km,kn))
        enddo
        enddo

        err=err/dfloat(nx*ny)

        if (err.lt.eps) then
        print*,eps,err
        goto 505
        endif

        end do
        end do

 505   open(unit=2,file='iter.txt',status='unknown',access='append')
       write(2,*),'GSLineADI     ','iter = ',iter,'omega =  ',w
       close(unit=2)
       return
       end
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C      Jacobi line Method  (ADI)                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CC     First step
CCCCCCCCCCCCCCCCCCCCCCCccccCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       subroutine JLineADI(nx,ny,betaw,beta,err,eps,w,dx,dy,tn,tn1,tn12
     c                          ,iter)

        integer nx,ny
        real*8 tn12(nx,ny),a(nx),b(nx),tn(nx,ny)
        real*8 c(nx),d(nx),tn1(nx,ny)
        real*8 betaw,beta,err,eps,w,dx,dy

        print*, "Jacobi line Method  (ADI)"

        do iter=1,1000000
        if(Modulo(iter,1000000).eq.6) then
                print*, "Jacobi Line (ADI) iteration number = ", iter
            endif
        do j=2,ny-1
        do i=2,nx-1
        a(i)=-w
        b(i)=betaw
        c(i)=-w
      d(i)=betaw*tn(i,j)+w*(beta*(tn(i,j-1)+tn(i,j+1))
     c -betaw*tn(i,j))
        end do
        a(1)=0.0d+00
        a(nx-1)=0.0d+00

      d(2)=betaw*tn(2,j)+w*(beta*(tn(2,j-1)+tn(2,j+1))
     c -betaw*tn(2,j))+w*tn(1,j)

      d(nx-1)=betaw*tn(nx-1,j)+w*(beta*(tn(nx-1,j-1)+
     c tn(nx-1,j+1))-betaw*tn(nx-1,j))+w*tn(nx,j)

        c(nx-1)=0.0d+00

        do k=3,nx-1
        b(k)=b(k)-(c(k-1)*a(k-1))/b(k-1)
        d(k)=d(k)-(d(k-1)*a(k-1))/b(k-1)
        end do
        tn12(nx-1,j)=d(nx-1)/b(nx-1)
        do m=nx-2,2,-1
        tn12(m,j)=(d(m)-c(m)*tn12(m+1,j))/b(m)
        end do
        end do
	do n=2,nx-1
        do nk=2,ny-1
        a(nk)=-w*beta
        b(nk)=betaw
        c(nk)=-w*beta

      d(nk)=betaw*tn12(n,nk)+w*((tn12(n-1,nk)+
     c tn12(n+1,nk))-betaw*tn12(n,nk))

        end do
        a(1)=0.0d+00
        a(nx-1)=0.0d+00

      d(2)=betaw*tn12(n,2)+w*((tn12(n-1,2)+tn12(n+1,2))
     c -betaw*tn12(n,2))+w*beta*tn12(n,1)

      d(nx-1)=betaw*tn12(n,ny-1)+w*((tn12(n-1,ny-1)+
     c tn12(n+1,ny-1))-betaw*tn12(n,ny-1))+w*beta*tn12(n,ny)

        do ii=3,ny-1
        b(ii)=b(ii)-(c(ii-1)*a(ii-1))/b(ii-1)
        d(ii)=d(ii)-(d(ii-1)*a(ii-1))/b(ii-1)
        end do
	tn1(n,ny-1)=d(ny-1)/b(ny-1)
        do ii=ny-2,2,-1
	tn1(n,ii)=(d(ii)-c(ii)*tn1(n,ii+1))/b(ii)
        end do
        do ni=1,ny
        do ki=1,nx
        tn(ki,ni)=tn1(ki,ni)
        end do
        end do
        do nn=1,ny-1
        do mn=1,nx
       err=err+dabs(tn12(mn,nn)-tn1(mn,nn))
        enddo
        enddo

        err=err/dfloat(nx*ny)

        if (err.lt.eps) then
        print*,eps,err
        goto 506
        endif

         enddo
         end do

 506   open(unit=2,file='iter.txt',status='unknown',access='append')
       write(2,*),'JLineADI    ','iter = ',iter,'omega =  ',w
       close(unit=2)
       return

       end