!->Copyright by The University of Michigan, Aerospace Department. 2003
!
!->Module LIB_LU. Rafa Palacios. 22Jun2003
!
!->Description.-
!
!  Matrix operations using LU decomposition.
!
!->Subroutines.-
!
!   lu_bksubs:    LU back-substitution.
!   lu_decomp:    LU decomposition of a general square matrix.
!   lu_determ:    Determinant of a square matrix.
!   lu_invers:    Inversion of a square matrix.
!   lu_sparse:    Inverse of Sparse matrix/vector product
!
!-> Modifications.-
! 20120317 A.Da Ronch Subroutine lu_sparse added
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module lib_lu
 implicit none
!
!   (There are no public variables in this module).
!
 contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine LU_BKSUBS.
!
!->Description.-
!
!   Solves the set of N linear equations A�X=B. A is given by its LU decomposition.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine lu_bksubs (A, INDX, B)
!
!-> I/O Variables.
!
  real(8), intent(in)   :: A(:,:)
  integer, intent(in)   :: INDX(:)
  real(8), intent(inout):: B(:)
!
!-> Local Variables.
!
  integer :: N               ! Size of the matrices.
  integer :: I, II, LL, J
  real(8) :: Sum
!
      n= size(A,1)
!
      II = 0
      DO I = 1, N
        LL = INDX(I)
        SUM = B(LL)
        B(LL) = B(I)
        IF(II.NE.0)THEN
          DO J = II, I-1
            SUM = SUM - A(I, J)*B(J)
          END DO
      ELSEIF(abs(SUM)>1e-20)THEN
          II = I
        ENDIF
        B(I) = SUM
      END DO
!
      DO I = N, 1, -1
        SUM = B(I)
        IF(I.LT.N)THEN
          DO J = I+1, N
            SUM = SUM - A(I, J)*B(J)
          END DO
        ENDIF
        B(I) = SUM/A(I, I)
      END DO
!
  return
 end subroutine lu_bksubs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine LU_DECOMP.
!
!->Description.-
!
!   LU Decomposition of a NxN Matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine lu_decomp (A, INDX, D)
!
!-> I/O Variables.
!
  real(8), intent(inout):: A(:,:)
  integer, intent(out)  :: INDX(:)
  real(8), intent(out)  :: D
!
!-> Local Variables.
!
  integer :: i,j,k                   ! Counters.
  integer :: imax                    ! Max Counter.
  integer :: N                       ! Size of the matrices.
  real(8) :: Aamax, Sum, Dum
  real(8), allocatable :: VV (:)     ! Stores the implicit scaling of each row.
!
  real(8), parameter :: Tiny=1.0d-20 ! Small number.
!
!
      n= size(A,1)
      allocate (VV(N))
      imax = 0
!
      D = 1.0
      DO I = 1, N
        AAMAX = 0.0
        DO J = 1, N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
        END DO
        IF(abs(AAMAX)<Tiny) then
            ! call backtrace()
            STOP 'Singular matrix'
        end if
        VV(I:I) = 1.d0/AAMAX
      END DO
!
      DO J = 1, N
        DO I = 1, J-1
          SUM = A(I, J)
          DO K = 1, I-1
            SUM = SUM - A(I, K)*A(K, J)
          END DO
          A(I, J) = SUM
        END DO
!
        AAMAX = 0.0
        DO I = J, N
          SUM = A(I, J)
          DO K = 1, J-1
            SUM = SUM - A(I, K)*A(K, J)
          END DO
          A(I, J) = SUM
          DUM = VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX)THEN
            IMAX = I
            AAMAX = DUM
          ENDIF
        END DO
        IF(J.NE.IMAX)THEN
          DO K = 1, N
            DUM = A(IMAX, K)
            A(IMAX, K) = A(J, K)
            A(J, K) = DUM
          END DO
          D = -D
          VV(IMAX) = VV(J)
        ENDIF
        INDX(J) = IMAX
        IF(abs(A(J, J))<Tiny) A(J, J) = TINY
        IF(J.NE.N)THEN
          DUM = 1.0/A(J, J)
          DO I = J+1, N
            A(I, J) = A(I, J)*DUM
          END DO
        ENDIF
      END DO
!
  deallocate (VV)
  return
 end subroutine lu_decomp

 function inv(A) result(Ainv)
  real(8), dimension(:,:), intent(in) :: A
  real(8), dimension(size(A,1),size(A,2)) :: Ainv

  real(8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: n, info

  integer :: i, j, m

  ! External procedures defined in LAPACK
  external DGETRF
  external DGETRI

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A, 1)
  m = size(A, 2)
 !  if (maxval(abs(A)) > 1e12) then
 !      open(unit=2, file='matrix.txt', ACTION="write", STATUS="replace")
 !      print*, 'UPPPSSSSS'
 !      do i=1, n
 !         write(2, '(*(2X e18.7))')((A(i,j)) ,j=1,M)
 !      end do
 !     close(2)
 !     read(*,*)
 ! end if
  ! DGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call DGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     stop 'Matrix is numerically singular!'
  end if

  ! DGETRI computes the inverse of a matrix using the LU factorization
  ! computed by DGETRF.
  call DGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if
end function inv

!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine LU_INVERS.
!
!->Description.-
!
!   Invert a matrix using LU Decomposition. It can also return the determinant.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine lu_invers (Matrix, InvMatrix, Det)
!
!-> I/O Variable.
!
  real(8),intent(in) :: Matrix(:,:)
  real(8),intent(out):: InvMatrix(:,:)
  real(8),optional,intent(out):: Det

!-> Local variables.
!
  integer::i,N
  real(8) :: D
  real(8), allocatable :: MatrixLU(:,:)
  integer, allocatable :: Indexes(:)
!
! Set dimension and the auxiliary vector.
!
  N= size(Matrix,1)
  allocate (Indexes(N)); Indexes = 0
  allocate (MatrixLU(N,N))
!
! Initialize InvMatrix as the identity matrix and MatrixLU as Matrix.
!
  MatrixLU=Matrix
!
  InvMatrix=0.d0
  do i=1,N
    InvMatrix(i,i)=1.d0
  end do
!
! LU Decomposition.
!
  call lu_decomp (MatrixLU,Indexes,D)
!
! The inverse is the solution to units vectors.
!
  do i=1,N
    call lu_bksubs (MatrixLU,Indexes,InvMatrix(:,i))
  end do
!
! Return the determinant of the matrix.
!
  if (present(Det)) then
    Det=D
    do i=1,N
      Det=Det*MatrixLU(i,i)
    end do
  end if
!
  return
 end subroutine lu_invers

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine LU_DETERM.
!
!->Description.-
!
!   Invert a matrix using LU Decomposition.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine lu_determ (Matrix, Det)
!
!-> I/O Variable.
!
  real(8), intent(in) :: Matrix(:,:)
  real(8), intent(out):: Det
!
!-> Local variables.
!
  integer::i,N
  real(8), allocatable :: MatrixLU(:,:)
  integer, allocatable :: Indexes(:)
!
! Set dimension and the auxiliary vector.
!
  N= size(Matrix,1)
  allocate (Indexes(N))
  allocate (MatrixLU(N,N)); MatrixLU=Matrix
!
! LU Decomposition.
!
  call lu_decomp (MatrixLU,Indexes,Det)
!
! The determinant of a LU decomposed matrix is just the product of the
! diagonal elements.
!
  do i=1,N
    Det=Det*MatrixLU(i,i)
  end do

  deallocate(MatrixLU)
  deallocate(Indexes)
!
  return
 end subroutine lu_determ
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!->Subroutine LU_SPARSE
!
!->Description.-
!
!   Inverse of sparse matrix/vector product.
!
!-> Modifications.-
! 20120317 A.Da Ronch Subroutine added for NOLAPACK conditional compilation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    subroutine lu_sparse(dimSprMat, SprMat, b, X)
        use lib_sparse
        integer,     intent(in) :: dimSprMat     ! Current storage dimension
        type(sparse),intent(in) :: SprMat(:)     ! Sparse matrix
        real(8),     intent(in) :: b(:)          ! Forcing vector
        real(8),     intent(out):: X(:)          ! Solution vector
        real(8),allocatable     :: FulMat(:,:)   ! Full matrix
        real(8),allocatable     :: invFulMat(:,:)! Full matrix
        integer:: dimb

        dimb=size(b)

        ! allocate(invFulMat(dimb,dimb))
        !
        ! ! Calculate the inverse
        ! ! call lu_invers(FulMat, invFulMat)
        ! invFulMat = inv(SprMat(1)%a)
        !
        ! ! Calculate matrix-vector product
        ! ! X=0.0d0
        ! ! do i1=1,dimb
        ! ! !   do i2=1,dimb
        ! !         ! original
        ! !         X(i1) = X(i1) + dot_product(invFulMat(i1,:), b(:))
        ! !     ! end do
        ! ! end do
        ! X = MATMUL(invFulMat, b)
        !
        ! deallocate(invFulMat)
        call lu_solve(size(SprMat(1)%a, dim=1), SprMat(1)%a, b, X)
        return
    end subroutine lu_sparse
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    subroutine lu_solve(numdof,A, b, X, balancing)
        !use, intrinsic :: IEEE_ARITHMETIC
        use, intrinsic :: ISO_C_BINDING
        integer, intent(IN)     :: numdof
        real(8), intent(IN)     :: A(numdof, numdof)
        real(8), intent(in)     :: b(numdof)          ! Forcing vector
        real(8), intent(out)    :: X(numdof)          ! Solution vector
        ! real(8),allocatable     :: invFulMat(:,:)! Full matrix
        logical(c_bool), optional       :: balancing
        integer:: dimb
        real(8)                 :: r(numdof)
        real(8)                 :: c(numdof)
        real(8)                 :: rcond
        real(8)                 :: ferr(1)
        real(8)                 :: berr(1)
        real(8)                 :: work(4*numdof)
        integer                 :: iwork(numdof)
        integer                 :: info
        integer                 :: ipivot(numdof)
        character               :: equed
        character               :: fact
        character               :: trans
        integer                 :: unit
        integer                 :: i

        ! real(8),allocatable     :: A_copy(:,:)
        real(8)                 :: A_copy(numdof, numdof)
        real(8)                 :: b_copy(numdof)
        real(8)                 :: AF(numdof, numdof)
        ! real(8)                 :: work(size(A, dim=1)*4)
        ! integer                 :: iwork(size(A, dim=1))
        integer                 :: nrows
        logical                 :: with_balancing

        !if (any(ieee_is_nan(A))) then
             !open(newunit=unit, file='debug_failed_Asys.txt')
             !do i=1, size(A(:,1))
                 !write(unit,*)A(i, :)
             !end do
             !close(unit)
            !STOP 'NaN in lu_solve'
        !end if

        A_copy = A
        X = b
        b_copy = b
        nrows = size(b)

        ! solve system
        with_balancing = .FALSE.
        if (present(balancing)) then
            if (balancing) then
                with_balancing = .TRUE.
            end if
        end if
        if (.NOT. with_balancing) then
            call dgesv(numdof,&
                       1,&
                       A_copy,&
                       numdof,&
                       ipivot,&
                       x,&
                       numdof,&
                       info)
        else
            fact = 'E'
            trans = 'N'
            call dgesvx(fact,&
                        trans,&
                        numdof,&
                        1,&
                        A_copy,&
                        numdof,&
                        AF,&
                        numdof,&
                        ipivot,&
                        equed,&
                        r,&
                        c,&
                        b_copy,&
                        numdof,&
                        x,&
                        numdof,&
                        rcond,&
                        ferr,&
                        berr,&
                        work,&
                        iwork,&
                        info)
        end if

        if (info /= 0) then
            print*, 'Info in DGESV = ', info
             open(newunit=unit, file='debug_failed_Asys.txt')
             do i=1, size(A(:,1))
                 write(unit,*)A(i, :)
             end do
             close(unit)
            stop
        end if
        ! deallocate(A_copy)
        return
    end subroutine lu_solve
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

end module lib_lu


*
* gradepretty - Calculate student grades based on partial scores
*
* The program will prompt for student grades until EOF is entered
*
* The final grade is 30% programs, 50% tests and 20% homework
*
* Grades are assigned based on the following scale:
*
*    >0.90 4.0
*    >0.80 3.0
*    >0.70 2.0
*    <0.60 0.0
*
*  Written by: C. Severance 16Mar92
*
      REAL PPER,TPER,HPER,PERCENT,TOTPER,AVEPER,GPA,TOTGPA,AVEGPA
      INTEGER STUDENT,COUNT
*
* Initialization and headings
*
      TOTPER = 0
      TOTGPA=0
      COUNT = 0
      PRINT 80
80    FORMAT(/'Grade program - written by Charles Severance'/)
*
* Read the three percentages.  Note that data is expected from
* a file so there is no prompt.
*
10    READ(*,*,END=20)STUDENT,PPER,TPER,HPER
*
      COUNT = COUNT + 1
*
      PERCENT = PPER * 0.30 + TPER * 0.50 + HPER * 0.20
      TOTPER = TOTPER + PERCENT
*
* Determine the final grade and add it to the running total for GPA
*
      GPA = 0.0
      IF ( PERCENT .GE. 0.90 ) THEN
        GPA = 4.0
      ELSE IF ( PERCENT .GE. 0.80 ) THEN
        GPA = 3.0
      ELSE IF ( PERCENT .GE. 0.70 ) THEN
        GPA = 2.0
      ENDIF
*
      TOTGPA = TOTGPA + GPA
*
* Print out the student information
*
      PRINT 100,STUDENT,PPER,TPER,HPER,PERCENT,GPA
100   FORMAT(1X,I9,3X,F7.2,3X,F7.2,3X,F7.2,3X,F7.2,3X,F5.2)
      GOTO 10
*
20    CONTINUE
*
* Calculate the averages
*
      IF ( COUNT.EQ.0 ) THEN
        AVEGPA = 0.0
        AVEPER = 0.0
      ELSE
        AVEGPA = TOTGPA/COUNT
        AVEPER = TOTPER/COUNT
      ENDIF
*
* Print them out
*
      PRINT 200,AVEPER,AVEGPA
200   FORMAT(/'Average',36X,F7.2,3X,F5.2)
      END


chapter xii, example 2. cubic spline interpolation with good knots
c  from  * a practical guide to splines *  by c. de boor
calls  cubspl, newnot
c     parameter nmax=20
      integer i,istep,iter,itermx,j,n,nhigh,nlow,nm1
c     real algerp,aloger,decay,dx,errmax,c(4,nmax),g,h,pnatx
c    *	  ,scrtch(2,nmax),step,tau(nmax),taunew(nmax)
      real algerp,aloger,decay,dx,errmax,c(4,20),g,h,pnatx
     *	  ,scrtch(2,20),step,tau(20),taunew(20),x
c     istep and step = float(istep) specify point density for error det-
c     ermination.
      data step, istep /20., 20/
c				the function  g  is to be interpolated .
      g(x) = sqrt(x+1.)
      decay = 0.
c      read in the number of iterations to be carried out and the lower
c      and upper limit for the number  n  of data points to be used.
      read 500,itermx,nlow,nhigh
  500 format(3i3)
      print 600, itermx
  600 format(i4,22h cycles through newnot//
     *	    28h  n   max.error	 decay exp./)
c				  loop over  n = number of data points .
      do 40 n=nlow,nhigh,2
c					 knots are initially equispaced.
	 nm1 = n-1
	 h = 2./float(nm1)
	 do 10 i=1,n
   10	    tau(i) = float(i-1)*h - 1.
	 iter = 1
c		construct cubic spline interpolant. then, itermx  times,
c		 determine new knots from it and find a new interpolant.
   11	    do 15 i=1,n
   15	       c(1,i) = g(tau(i))
	    call cubspl ( tau, c, n, 0, 0 )
	    if (iter .gt. itermx)	go to 19
	    iter = iter+1
	    call newnot(tau,c,nm1,4,taunew,nm1,scrtch)
	    do 18 i=1,n
   18	       tau(i) = taunew(i)
					go to 11
   19	 continue
c			     estimate max.interpolation error on (-1,1).
	 errmax = 0.
c			    loop over polynomial pieces of interpolant .
	 do 30 i=1,nm1
	    dx = (tau(i+1)-tau(i))/step
c		 interpolation error is calculated at  istep  points per
c		     polynomial piece .
	    do 30 j=1,istep
	       h = float(j)*dx
	       pnatx = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
   30	    errmax = amax1(errmax,abs(g(tau(i)+h)-pnatx))
c					      calculate decay exponent .
	 aloger = alog(errmax)
	 if (n .gt. nlow)  decay =
     *	     (aloger - algerp)/alog(float(n)/float(n-2))
	 algerp = aloger
c
   40	 print 640,n,errmax,decay
  640 format(i3,e12.4,f11.2)
					stop
      end


submodule (stdlib_stats) stdlib_stats_cov

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  implicit none

contains

    module function cov_1_rdp_rdp(x, dim, mask, corrected) result(res)
      real(dp), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      real(dp) :: res

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      res = var(x, dim, corrected = optval(corrected, .true.))

    end function cov_1_rdp_rdp
    module function cov_1_cdp_cdp(x, dim, mask, corrected) result(res)
      complex(dp), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      real(dp) :: res

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      res = var(x, dim, corrected = optval(corrected, .true.))

    end function cov_1_cdp_cdp

    module function cov_1_iint32_dp(x, dim, mask, corrected) result(res)
      integer(int32), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      real(dp) :: res

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      res = var(x, dim, corrected = optval(corrected, .true.))

    end function cov_1_iint32_dp

    module function cov_mask_1_rdp_rdp(x, dim, mask, corrected) result(res)
      real(dp), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:)
      logical, intent(in), optional :: corrected
      real(dp) :: res

      res = var(x, dim, mask, corrected = optval(corrected, .true.))

    end function cov_mask_1_rdp_rdp
    module function cov_mask_1_cdp_cdp(x, dim, mask, corrected) result(res)
      complex(dp), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:)
      logical, intent(in), optional :: corrected
      real(dp) :: res

      res = var(x, dim, mask, corrected = optval(corrected, .true.))

    end function cov_mask_1_cdp_cdp

    module function cov_mask_1_iint32_dp(x, dim, mask, corrected) result(res)
      integer(int32), intent(in) :: x(:)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:)
      logical, intent(in), optional :: corrected
      real(dp) :: res

      res = var(x, dim, mask, corrected = optval(corrected, .true.))

    end function cov_mask_1_iint32_dp

    module function cov_2_rdp_rdp(x, dim, mask, corrected) result(res)
      real(dp), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                          , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i
      real(dp) :: mean_(merge(size(x, 1), size(x, 2), mask = 1<dim))
      real(dp) :: center(size(x, 1),size(x, 2))

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      mean_ = mean(x, dim)
      select case(dim)
        case(1)
          do i = 1, size(x, 1)
            center(i, :) = x(i, :) - mean_
          end do
            res = matmul( transpose(center), center)
        case(2)
          do i = 1, size(x, 2)
            center(:, i) = x(:, i) - mean_
          end do
            res = matmul( center, transpose(center))
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select
      res = res / (size(x, dim) - merge(1, 0, optval(corrected, .true.)))

    end function cov_2_rdp_rdp
    module function cov_2_cdp_cdp(x, dim, mask, corrected) result(res)
      complex(dp), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      complex(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                          , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i
      complex(dp) :: mean_(merge(size(x, 1), size(x, 2), mask = 1<dim))
      complex(dp) :: center(size(x, 1),size(x, 2))

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      mean_ = mean(x, dim)
      select case(dim)
        case(1)
          do i = 1, size(x, 1)
            center(i, :) = x(i, :) - mean_
          end do
            res = matmul( transpose(conjg(center)), center)
        case(2)
          do i = 1, size(x, 2)
            center(:, i) = x(:, i) - mean_
          end do
            res = matmul( center, transpose(conjg(center)))
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select
      res = res / (size(x, dim) - merge(1, 0, optval(corrected, .true.)))

    end function cov_2_cdp_cdp

    module function cov_2_iint32_dp(x, dim, mask, corrected) result(res)
      integer(int32), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in), optional :: mask
      logical, intent(in), optional :: corrected
      real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                      , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i
      real(dp) :: mean_(merge(size(x, 1), size(x, 2), mask = 1<dim))
      real(dp) :: center(size(x, 1),size(x, 2))

      if (.not.optval(mask, .true.)) then
        res = ieee_value(1._dp, ieee_quiet_nan)
        return
      end if

      mean_ = mean(x, dim)
      select case(dim)
        case(1)
          do i = 1, size(x, 1)
            center(i, :) = real(x(i, :), dp) - mean_
          end do
          res = matmul( transpose(center), center)
        case(2)
          do i = 1, size(x, 2)
            center(:, i) = real(x(:, i), dp) - mean_
          end do
          res = matmul( center, transpose(center))
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select
      res = res / (size(x, dim) - merge(1, 0, optval(corrected, .true.)))

    end function cov_2_iint32_dp

    module function cov_mask_2_rdp_rdp(x, dim, mask, corrected) result(res)
      real(dp), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:,:)
      logical, intent(in), optional :: corrected
      real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                          , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i, j, n
      real(dp) :: centeri_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      real(dp) :: centerj_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      logical :: mask_(merge(size(x, 2), size(x, 1), mask = 1<dim))

      select case(dim)
        case(1)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
             mask_ = merge(.true., .false., mask(:, i) .and. mask(:, j))
             centeri_ = merge( x(:, i) - mean(x(:, i), mask = mask_),&
                0._dp,&
                mask_)
             centerj_ = merge( x(:, j) - mean(x(:, j), mask = mask_),&
                0._dp,&
                mask_)

              n = count(mask_)
              res(j, i) = dot_product( centerj_, centeri_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case(2)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
             mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :))
             centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),&
                0._dp,&
                mask_)
             centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),&
                0._dp,&
                mask_)

              n = count(mask_)
              res(j, i) = dot_product( centeri_, centerj_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select

    end function cov_mask_2_rdp_rdp
    module function cov_mask_2_cdp_cdp(x, dim, mask, corrected) result(res)
      complex(dp), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:,:)
      logical, intent(in), optional :: corrected
      complex(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                          , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i, j, n
      complex(dp) :: centeri_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      complex(dp) :: centerj_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      logical :: mask_(merge(size(x, 2), size(x, 1), mask = 1<dim))

      select case(dim)
        case(1)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
             mask_ = merge(.true., .false., mask(:, i) .and. mask(:, j))
             centeri_ = merge( x(:, i) - mean(x(:, i), mask = mask_),&
                cmplx(0,0,kind=dp),&
                mask_)
             centerj_ = merge( x(:, j) - mean(x(:, j), mask = mask_),&
                cmplx(0,0,kind=dp),&
                mask_)

              n = count(mask_)
              res(j, i) = dot_product( centerj_, centeri_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case(2)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
             mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :))
             centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),&
                cmplx(0,0,kind=dp),&
                mask_)
             centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),&
                cmplx(0,0,kind=dp),&
                mask_)

              n = count(mask_)
              res(j, i) = dot_product( centeri_, centerj_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select

    end function cov_mask_2_cdp_cdp

    module function cov_mask_2_iint32_dp(x, dim, mask, corrected) result(res)
      integer(int32), intent(in) :: x(:, :)
      integer, intent(in) :: dim
      logical, intent(in) :: mask(:,:)
      logical, intent(in), optional :: corrected
      real(dp) :: res(merge(size(x, 1), size(x, 2), mask = 1<dim)&
                          , merge(size(x, 1), size(x, 2), mask = 1<dim))

      integer :: i, j, n
      real(dp) :: centeri_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      real(dp) :: centerj_(merge(size(x, 2), size(x, 1), mask = 1<dim))
      logical :: mask_(merge(size(x, 2), size(x, 1), mask = 1<dim))

      select case(dim)
        case(1)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
              mask_ = merge(.true., .false., mask(:, i) .and. mask(:, j))
              centeri_ = merge( x(:, i) - mean(x(:, i), mask = mask_),&
                 0._dp, mask_)
              centerj_ = merge( x(:, j) - mean(x(:, j), mask = mask_),&
                 0._dp, mask_)

              n = count(mask_)
              res(j, i) = dot_product( centerj_, centeri_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case(2)
          do i = 1, size(res, 2)
            do j = 1, size(res, 1)
              mask_ = merge(.true., .false., mask(i, :) .and. mask(j, :))
              centeri_ = merge( x(i, :) - mean(x(i, :), mask = mask_),&
                 0._dp, mask_)
              centerj_ = merge( x(j, :) - mean(x(j, :), mask = mask_),&
                 0._dp, mask_)

              n = count(mask_)
              res(j, i) = dot_product( centeri_, centerj_)&
                           / (n - merge(1, 0,&
                            optval(corrected, .true.) .and. n > 0))
            end do
          end do
        case default
          call error_stop("ERROR (cov): wrong dimension")
      end select

    end function cov_mask_2_iint32_dp

end submodule


module array_utils

	implicit none

	interface ones_like
		procedure ones_like_1d
		procedure ones_like_2d
	end interface ones_like

contains

subroutine fill_matrix_with_value(A, val)
	! Set all the elements of matrix A[m x n] to be val
	implicit none
	real(kind=8), dimension(:,:), intent(inout) :: A
	real(kind=8), intent(in) :: val

	A = val

end subroutine fill_matrix_with_value

subroutine set_diagonal_to(A, val)
	! Set diagonal elements of matrix A[m x n] to be val
	implicit none
	real(kind=8), dimension(:,:), intent(inout) :: A
	real(kind=8), intent(in) :: val

	! local variable
	integer :: i

	FORALL (i=1:minval(shape(A)))  A(i, i) = val

end subroutine set_diagonal_to

subroutine add_value_to_diagonal(A, val)
	! Add value val to diagonal elements of matrix A[m x n]
	implicit none
	real(kind=8), dimension(:,:), intent(inout) :: A
	real(kind=8), intent(in) :: val

	! local variable
	integer :: i

	FORALL (i=1:minval(shape(A)))  A(i,i) = A(i,i) + val

end subroutine add_value_to_diagonal

subroutine add_array_to_diagonal(A, arr)
	! Add value val to diagonal elements of matrix A[m x n]
	implicit none
	real(kind=8), dimension(:,:), intent(inout) :: A
	real(kind=8), dimension(:), intent(in) :: arr

	! local variable
	integer :: i

	if (size(arr) /= minval(shape(A))) stop 'Size mismatch in add_array_to_diagonal'

	FORALL (i=1:minval(shape(A)))  A(i,i) = A(i,i) + arr(i)

end subroutine add_array_to_diagonal

function get_diagonal(A) result(diag)
	! Get diagonal elements of matrix A (general [m x n] dimensions)
	implicit none
	real(kind=8), dimension(:,:), intent(in) :: A
	real(kind=8), dimension(minval(shape(a))) :: diag
	! local variables
	integer :: i

	FORALL (i=1:size(diag)) diag(i) = A(i,i)

end function get_diagonal

function eye(n) result(A)
	! Create an [n x n] identity matrix
	implicit none
	integer, intent(in) :: n
	real(kind=8), dimension(n,n) :: A

	A = 0.d0
	call set_diagonal_to(A, 1.d0)
	return

end function eye

function ones_like_1d(arr) result(ones)
	implicit none
	real(kind=8), dimension(:), intent(in) :: arr
	real(kind=8), dimension(:), allocatable :: ones

	allocate(ones(size(arr)))
	ones = 1.d0
end function ones_like_1d

function ones_like_2d(arr) result(ones)
	implicit none
	real(kind=8), dimension(:,:), intent(in) :: arr
	real(kind=8), dimension(:,:), allocatable :: ones
	integer, dimension(2) :: dims

	dims = shape(arr)
	allocate(ones(dims(1), dims(2)))
	ones = 1.d0
end function ones_like_2d

function linspace(xmin, xmax, num) result(x)
    implicit none
    real(kind=8), intent(in) :: xmin, xmax
    integer, intent(in) :: num
    real(kind=8), dimension(num) :: x
    integer :: i
    if (num == 1) then
       if(xmin /= xmax) then
          write(0,'("ERROR: Cannot call linspace with n=1 and xmin /= xmax")')
          stop
       else
          x = xmin
       end if
    else
       do i=1,num
          x(i) = (xmax-xmin) * real(i-1, kind=8) / real(num-1, kind=8) + xmin
       end do
    end if
end function linspace

subroutine sort(A, N)
	! arguments
	integer, intent(in) :: N
	real(kind=8), dimension(N), intent(inout) :: A
	! local variables
	real(kind=8), dimension((N+1)/2) :: T

	call MergeSort(A,N,T)

	contains
		subroutine Merge(A,NA,B,NB,C,NC)

			integer, intent(in) :: NA,NB,NC         ! Normal usage: NA+NB = NC
			real(kind=8), intent(in out) :: A(NA)        ! B overlays C(NA+1:NC)
			real(kind=8), intent(in)     :: B(NB)
			real(kind=8), intent(in out) :: C(NC)

			integer :: I,J,K

			I = 1; J = 1; K = 1;
			do while(I <= NA .and. J <= NB)
				if (A(I) <= B(J)) then
					C(K) = A(I)
					I = I+1
				else
			 		C(K) = B(J)
					J = J+1
				endif
				K = K + 1
			enddo
			do while (I <= NA)
				C(K) = A(I)
				I = I + 1
				K = K + 1
			enddo
			return
		end subroutine merge

		recursive subroutine MergeSort(A,N,T)
			integer, intent(in) :: N
			real(kind=8), dimension(N), intent(in out) :: A
			real(kind=8), dimension((N+1)/2), intent (out) :: T

			integer :: NA, NB
			real(kind=8) :: V

			if (N < 2) return
			if (N == 2) then
				if (A(1) > A(2)) then
					V = A(1)
					A(1) = A(2)
					A(2) = V
				endif
				return
			endif
			NA=(N+1)/2
			NB=N-NA

			call MergeSort(A,NA,T)
			call MergeSort(A(NA+1),NB,T)

			if (A(NA) > A(NA+1)) then
				T(1:NA)=A(1:NA)
				call Merge(T,NA,A(NA+1),NB,A,N)
			endif
			return
		end subroutine MergeSort

end subroutine sort

end module array_utils


submodule(forlab_linalg) forlab_linalg_linspace

    implicit none

contains

    module procedure linspace_sp
    integer :: i, n
    real(sp) :: by
    n = size(X)
    by = (to - from)/real(n - 1, sp)
    X = from + by*real([(i - 1, i=1, n)], sp)
    return
    end procedure linspace_sp

    module procedure logspace_sp
    call linspace(X, log10(from), log10(to))
    X = 10._sp**X
    return
    end procedure logspace_sp
    module procedure linspace_dp
    integer :: i, n
    real(dp) :: by
    n = size(X)
    by = (to - from)/real(n - 1, dp)
    X = from + by*real([(i - 1, i=1, n)], dp)
    return
    end procedure linspace_dp

    module procedure logspace_dp
    call linspace(X, log10(from), log10(to))
    X = 10._dp**X
    return
    end procedure logspace_dp

end submodule forlab_linalg_linspace


program parallel_pi
  include "mpif.h"
  integer, parameter:: dp = kind(1.0d0)
  real(dp), parameter :: pi25 = 3.141592653589793238462643_dp
  integer :: n, i
  real(dp) :: pi, h, sum, x
  logical :: done

  integer :: myid, numprocs, ierr
  real(dp) :: mypi

  call MPI_Init(ierr)
  call MPI_Comm_size(MPI_COMM_WORLD, numprocs, ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD, myid, ierr)

  done = .false.

  do while ( .not.done)
     if (myid == 0) then
        write(*,'("Enter the number of intervals: (0 quits) ")')
        read(*,*) n
     endif

     call MPI_Bcast(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

     if (n == 0) exit

     h   = 1.0_dp/dble(n)
     sum = 0.0_dp

     do i = myid+1, n, numprocs
        x = h * (i - 0.5_dp)
        sum = sum + 4.0_dp/(1.0_dp + x*x)
     enddo

     mypi = h * sum

     call MPI_Reduce(mypi, pi, 1, MPI_DOUBLE_PRECISION, MPI_SUM, 0, &
          MPI_COMM_WORLD, ierr)

     if (myid == 0) then
        write(*,'(" pi is approximately ",f16.13," Error is ",f16.13)') &
             pi, abs(pi - pi25)
     end if
  end do

  call MPI_Finalize(ierr)

end program parallel_pi


!##############################################################################
! PROGRAM SummingUp
!
! ## Use do loops to sum up integer numbers successively
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program SummingUp

    implicit none
    integer :: i, j, sum

    ! read the variable
    write(*,'(a)')'Type an integer variable that is > 0'
    read(*,*)i

    ! check whether i > 0
    if(i > 0)then

        ! initialize sum at 0
        sum = 0

        ! do the summing up
        do j = 1, i
            sum = sum + j
        enddo

        ! write the result to the console
        write(*,'(a,i3,a,i10)')'The sum of 1 to ',i,' is ',sum

    else

        ! write the error message
        write(*,'(a)')'Error: i should be greater than 0'
    endif

end program


*
* Homework 5
* CPSC 4399-11; Special Topics: Monte Carlo Simulation
* Professor Minsker
* Connor P. Taffe
* T no. 00563742
*

      program main
          double precision sim
          print *, 'Simulated: ', sim()
      end

*
* Generates n random numbers on the range [1,n].
* returns the cardinality of the set of unique
* numbers generated.
*
      integer function unique(n)
          integer n, rnd
          logical seen(n)
          external rand
          double precision rand

* Intialize local variables.
          unique = 0
          do 10 i=1, n
              seen(i) = .false.
10            continue

*
* Loop n times, generating n random numbers
* on the range [1, n]. Returns the number of unique
* numbers (numbers only generated once).
*
          do 20 i=1, n
*
* Random number on range [1, 365].
* The rand function is implemented in C code using the C
* standard library's rand function, which returns
* on the range [0, RAND_MAX].
* The rand function divides that by RAND_MAX cast to a double
* to get a double precision floating point on the
* range [0, 1].
* Multiply with integer truncation yilds equal probablility
* of 0-n-1 and almost 0 proability of n. Thusly
* ([0, 1] * n)+1 => [1,n].
* Loop to avoid n's
*
          rnd = n+1
          do 30 while (rnd .eq. n+1)
              rnd = int(rand() * n)+1
30            continue

*
* "dist" is an array of size n, indexed on
* the range [1, n]. For each index, the corresponding
* entry is the number of times that index has been generated
* by this loop.
* On no previous generations, it is a unique value,
* so the unique count is incremented.
* On one previous generation, it is no longer unique,
* so the unique count is decremented.
*
              if (.not. seen(rnd)) then
                  unique = unique+1
                  seen(rnd) = .true.
              end if
20            continue
          return
      end

* Simulation function, returns mean.
      double precision function sim()
          integer n, m, unique
          parameter(m = 365, n = 100000)
          sim = 0
*
* Loop over n simulations.
* Sums unique values out of m trials.
*
          do 10 j=1, n
              sim = sim + unique(m)
10            continue
*
* Value of the simulation is the number of trails
* minus the total uniques out of the total simulations.
*
          sim = sim/n
          return
      end


! =====================================================================
! function ALAGUERRE
!
! alaguerre is an function that recursively computes the value of the
! associated Laguerre polynomial of degree n and order k at the point x.
! ---------------------------------------------------------------------
      DOUBLE PRECISION RECURSIVE FUNCTION alaguerre ( n , k , x ) RESULT ( alaguerreNK )

      IMPLICIT NONE

      INTEGER, INTENT ( IN ) :: n
      INTEGER, INTENT ( IN ) :: k

      DOUBLE PRECISION, INTENT ( IN ) :: x

      alaguerreNK = 0.0

      IF ( k > -1 ) THEN

         IF ( n == 0 ) THEN

            alaguerreNK = 1.0

         ELSE IF ( n == 1 ) THEN

            alaguerreNK = 1.0 + REAL ( k ) - x

         ELSE IF ( n >= 2 ) THEN

            alaguerreNK = ( ( 2.0 * REAL ( n ) + REAL ( k ) - 1.0 - x ) * alaguerre ( n - 1 , k , x ) - &
               & ( REAL ( n ) + REAL ( k ) - 1.0 ) * alaguerre ( n - 2 , k , x ) ) / REAL ( n )

         ELSE

            ! ERROR

         END IF

      ELSE

         ! ERROR

      END IF

      RETURN
      END FUNCTION
! =====================================================================


program main
    implicit none

    integer :: number
    integer, dimension(3) :: arr

    number = 1000

    arr = triplet(number)
    print *, arr

    print *, product(arr)

contains
function triplet(number)
    implicit none
    integer, intent(in) :: number
    integer, dimension(3) :: triplet
    integer :: a, b, c

    loopa: do a = 1, number
        do b = a, number
            c = number - a - b
            if (a*a + b*b == c*c) then
                exit loopa
            end if
        end do
    end do loopa

    triplet(1) = a
    triplet(2) = b
    triplet(3) = c

end function triplet

end program main


module functions
    contains

subroutine spaceevenly(start, finish, number, arrayout)
    implicit none

    integer, intent(in) :: start, finish
    real(kind=8), intent(in) :: number
    real(kind=8) :: div
    real(kind=8), dimension(0:finish), intent(out) :: arrayout
    integer :: i

    div = number / ((finish-1) - (start-1))

    do i=start, finish
        arrayout(i) = div * i
    end do

end subroutine spaceevenly

subroutine laplace2d(p, y, dx, dy, l1nom_target, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny
    real(kind=8), intent(in) :: dx, dy, l1nom_target
    real(kind=8), intent(in), dimension(nx) :: y
    real(kind=8), intent(out), dimension(nx, ny) :: p
    real(kind=8), dimension(nx, ny) :: pn
    integer :: i, j, l1norm = 1, whilecounter =1
    real(kind=8) :: derivYpow2, derivXpow2, F1term, S2term, numerator, denominator
    real(kind=8) :: lnorm_last, psum, pnsum

    derivYpow2 = dy**2
	derivXpow2 = dx**2

    ! Counter still not working with the l1norm condition
    do while (whilecounter < 708)! (l1norm > l1nom_target)
        pn = p
        do i = 2, nx-1
            do j = 2, ny-1
                F1term = p(j, i + 1) + p(j, i - 1)
                S2term = p(j + 1, i) + p(j - 1, i)
                numerator = (derivYpow2 * F1term) + (derivXpow2 * S2term)
                denominator = 2 * (derivXpow2 + derivYpow2)

                p(j,i) = numerator / denominator

                !print*, "in main while loop -> iteration:)", i, " - ", j
            end do
        end do

        ! Reset Boundary conditions
        call boundary_conditions(p, y, nx, ny)

        ! calculate l1norm
        do i = 1, nx
            do j = 1, ny
                psum = psum + abs(p(j,i))
				pnsum = pnsum + abs(pn(j,i))
            end do
        end do
        lnorm_last = l1norm
		l1norm = (psum - pnsum) / pnsum
    ! print*, "loop counter: ", whilecounter
    whilecounter = whilecounter +1
    end do

end subroutine

subroutine boundary_conditions(p, y, nx,ny)
    implicit none

    real(kind=8), intent(out), dimension(nx, ny) :: p
    real(kind=8), intent(in), dimension(nx) :: y
    integer, intent(in) :: nx, ny
    integer :: i

    do i=1, ny
        p(i,1) = 0
    end do

    do i=1, ny
        p(i,ny) = y(i)
    end do

    do i=1, nx
        p(1,i) = p(2,i)
    end do

    do i=1, nx
        p(nx,i) = p(nx-1,i)
    end do

end subroutine

subroutine diffuse(timesteps, u, nu, dt, dx, dy, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny, timesteps
    real(kind=8), intent(in) :: nu, dt, dx, dy
    real(kind=8), intent(out), dimension(nx,ny) :: u
    real(kind=8), dimension(nx,ny) :: un
    integer :: i, j, time
    real(kind=8) :: Ydisip, Xdisip, Yderiv, Xderiv
    time = timesteps

    do time = 1, time
            un = u

            do j=2, nx-1
                do i=2, ny-1
                    Xderiv = (nu * dt) / (dx**2)
                    Yderiv = (nu * dt) / (dy**2)
                    Xdisip = un(j,i+1) - (2 * un(j,i)) + un(j,i-1)
                    Ydisip = un(j+1,i) - (2 * un(j,i)) + un(j-1,i)

                    u(j,i) = un(j,i) + (Xderiv * Xdisip) + (Yderiv * Ydisip)

                    u(1,j) = 1
                    u(nx,j) = 1
                    u(i,1) = 1
                    u(i,ny) = 1

                    u(1,1) = 1
                    u(1,nx) = 1
                    u(ny,1) = 1
                    u(ny,nx) = 1
                end do
            end do
        end do
end subroutine

subroutine write_csv (unit_number, filename, p, nx, ny)
    implicit none
    integer,  intent(in) :: unit_number
    character(len = *),  intent(in) :: filename
    integer, intent(in) :: nx, ny
    real(kind=8), intent(in), dimension(nx,ny) :: p
    integer :: i, j

10  format (i1)
15  format (f10.5,",")
20  format ("")

    open(unit=unit_number, file=filename)
    do i=1, nx
        do j=1, ny
            write(unit=unit_number, fmt=15, advance="no"), p(i,j)
        end do
        write(unit=unit_number,fmt=20)
    end do

    close(unit=unit_number)

end subroutine

end module functions


data Bool = True
          | False

data Nat = Zero
         | S Nat

and :: Bool -> Bool -> Bool
and = [<True,True,True>, <True,False,False>, <False,True,False>, <False,False,False>]

isZero :: Nat -> Bool
isZero = [<Zero, True>, <S (S Zero), False>]

bothZero :: Nat -> Nat -> Bool
bothZero = [<Zero, Zero, True>, <S (S Zero), Zero, False>, <Zero, S Zero, False>]

main :: Unit
main = bothZero (Zero) (Zero)


program trace_nan
    use, intrinsic :: iso_fortran_env, only : dp => REAL64
    implicit none
    integer, parameter :: n = 4
    integer :: i
    real(kind=dp), parameter, dimension(n) :: a = [ 1.0_dp, 3.0_dp, &
                                                    -3.0_dp, 5.3_dp ]
    real(kind=dp), dimension(n) :: b

    do i = 1, n
        b(i) = sqrt(a(i))
    end do
    do i = 1, n
        print '(2F10.3)', a(i), b(i)
    end do

end program trace_nan


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

    use parameters_module

    implicit none

    ! Input arguments
    integer, intent(in) :: maxmx,meqn,mbc,mx,maux
    double precision, intent(in) :: xlower,dx

    double precision, intent(inout) :: q(1-mbc:maxmx+mbc,meqn)
    double precision, intent(inout) :: aux(1-mbc:maxmx+mbc,maux)

    ! Locals
    integer :: i
    double precision :: x,xmid,eigen_vector(4),gamma,lambda,alpha,h_1,h_2,deta

    if (.not.((0 <= init_type).and.(init_type <= 5))) then
        print "(a,i2)","Invalid initialization type requested, init_type = ",init_type
    endif

    do i=1,mx
        x = xlower+(i-0.5)*dx

        ! Set initial perturbation to zero and constant depths
        q(i,1) = aux(i,3) * rho(1)
        q(i,3) = aux(i,4) * rho(2)
        q(i,2) = 0.d0
        q(i,4) = 0.d0

        ! Simple Riemann problem specification
        if (init_type == 0) then
            ! Depth is already set above appropriately
            ! Need to set momentum though
            if (x < init_location) then
                q(i,2) = u_left(1) * q(i,1)
                q(i,4) = u_left(2) * q(i,3)
            else
                q(i,2) = u_right(1) * q(i,1)
                q(i,4) = u_right(2) * q(i,3)
            endif

        ! Riemann problem in one wave family
        else if (init_type == 1) then
            ! Calculate wave family for perturbation
            gamma = aux(i,4) / aux(i,3)
            select case(wave_family)
                case(1) ! Shallow water, left-going
                    alpha = 0.5d0 * (gamma - 1.d0 + sqrt((gamma-1.d0)**2+4.d0*r*gamma))
                    lambda = -sqrt(g*aux(i,3)*(1.d0+alpha))
                case(2) ! Internal wave, left-going
                    alpha = 0.5d0 * (gamma - 1.d0 - sqrt((gamma-1.d0)**2+4.d0*r*gamma))
                    lambda = -sqrt(g*aux(i,3)*(1.d0+alpha))
                case(3) ! Internal wave, right-going
                    alpha = 0.5d0 * (gamma - 1.d0 - sqrt((gamma-1.d0)**2+4.d0*r*gamma))
                    lambda = sqrt(g*aux(i,3)*(1.d0+alpha))
                case(4) ! Shallow water, right-going
                    alpha = 0.5d0 * (gamma - 1.d0 + sqrt((gamma-1.d0)**2+4.d0*r*gamma))
                    lambda = sqrt(g*aux(i,3)*(1.d0+alpha))
            end select
            eigen_vector = [1.d0,lambda,alpha,lambda*alpha]

            ! Add perturbation
            if ((x < init_location).and.(wave_family >= 3)) then
                q(i,1:2) = q(i,1:2) + rho(1) * epsilon * eigen_vector(1:2)
                q(i,3:4) = q(i,3:4) + rho(2) * epsilon * eigen_vector(3:4)
            else if ((x > init_location).and.(wave_family < 3)) then
                q(i,1:2) = q(i,1:2) + rho(1) * epsilon * eigen_vector(1:2)
                q(i,3:4) = q(i,3:4) + rho(2) * epsilon * eigen_vector(3:4)
            endif
        ! Gaussian hump of water, shallow water style
        else if (init_type == 2) then
            gamma = aux(i,4) / aux(i,3)
            alpha = 0.5d0 * (gamma - 1.d0 + sqrt((gamma-1.d0)**2+4.d0*r*gamma))
            deta = epsilon * exp(-((x-init_location)/sigma)**2)
            q(i,1) = q(i,1) + rho(1) * deta
            q(i,3) = q(i,3) + rho(2) * alpha * deta
        ! Gaussian on internal layer only
        else if (init_type == 3) then
            deta = epsilon * exp(-((x-init_location)/sigma)**2)
            q(i,1) = q(i,1) - rho(1) * deta
            q(i,3) = q(i,3) + rho(2) * deta
        ! Shelf initial condition from AN paper
        else if (init_type == 4) then
            gamma = aux(i,4) / aux(i,3)
!             alpha = 0.5d0 * (gamma - 1.d0 + sqrt((gamma-1.d0)**2+4.d0*r*gamma))
            alpha = 0.d0
            xmid = 0.5d0*(-180.e3-80.e3)
            if ((x > -130.e3).and.(x < -80.e3)) then
                deta = epsilon * sin((x-xmid)*PI/(-80.e3-xmid))
                q(i,3) = q(i,3) + rho(2) * alpha * deta
                q(i,1) = q(i,1) + rho(1) * deta * (1.d0 - alpha)
            endif
        endif
    enddo

end subroutine qinit


use ArrayClass
implicit none

type(Array_) :: array1, array2

array1 = to_array([1,2,3],[4,5,6],[7,8,9],dtype="float")
array2 = to_array([0,0,1],dtype="float")

! matrix-vector multiplication
array1 = matmul(array1, array2)

!array1 = array1%T() ! transpose
! or
!array1 = transpose(array1)

print *, array1%dtype
call print(array1)

end


      subroutine sft(x,n,om,ct,st)
c
c  calculates fourier transform of real sequence x(i),i=1,...n
c  at angular frequency om normalized so that nyquist=pi. the sine
c  transform is returned in st and the cosine transform in ct.
c  algorithm is that of goertzal with modifications by
c  gentleman, comp.j. 1969
c  transform is not normalized
c  to normalize one-sided ft, divide by sqrt(data length)
c  for positive om, the ft is defined as ct-(0.,1.)st or like slatec
c  cfftf
c
      implicit double precision (a-h,o-z)
      parameter (pi=3.141592653589793238d0,tp=2.d0*pi)
      dimension x(n)
      np1=n+1
      l=6.d0*om/tp
      s=sin(om)
      a=0.d0
      c=0.d0
      d=0.d0
      e=0.d0
      if(l.eq.0)then
c  recursion for low frequencies (.lt. nyq/3)
        b=-4.d0*sin(om/2.d0)**2
        do 10 k=1,n
          c=a
          d=e
          a=x(np1-k)+b*d+c
   10     e=a+d
      elseif(l.eq.1)then
c  regular goertzal algorithm for intermediate frequencies
        b=2.d0*cos(om)
        do 20 k=1,n
          a=x(np1-k)+b*e-d
          d=e
   20     e=a
      else
c  recursion for high frequencies (.gt. 2*nyq/3)
        b=4.d0*cos(om/2.d0)**2
        do 30 k=1,n
          c=a
          d=e
          a=x(np1-k)+b*d-c
   30     e=a-d
      endif
      st=-s*d
      ct=a-b*d/2.d0
      return
      end

c $Id$


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(vorticity_routines) vorticity_gaussian_grid

contains

    !     subroutine vrtgc(nlat, nlon, isym, nt, vort, ivrt, jvrt, cr, ci, mdc, ndc, &
    !                      wshsgc, ierror)
    !
    !     given the vector spherical harmonic coefficients cr and ci, precomputed
    !     by subroutine vhagc for a vector field (v, w), subroutine vrtgc
    !     computes the vorticity of the vector field in the scalar array
    !     vort.  vort(i, j) is the vorticity at the gaussian colatitude
    !     theta(i) (see nlat as input parameter) and longitude
    !     lambda(j) = (j-1)*2*pi/nlon on the sphere.  i.e.,
    !
    !            vort(i, j) =  [-dv/dlambda + d(sint*w)/dtheta]/sint
    !
    !     where sint = sin(theta(i)).  w is the east longitudinal and v
    !     is the colatitudinal component of the vector field from which
    !     cr, ci were precomputed.  required associated legendre polynomials
    !     are recomputed rather than stored as they are in subroutine vrtgs.
    !
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than 3. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   a parameter which determines whether the vorticity is
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !            the symmetries/antsymmetries described in isym=1, 2 below
    !            do not exist in (v, w) about the equator.  in this case the
    !            vorticity is neither symmetric nor antisymmetric about
    !            the equator.  the vorticity is computed on the entire
    !            sphere.  i.e., in the array vort(i, j) for i=1, ..., nlat and
    !            j=1, ..., nlon.
    !
    !      = 1
    !            w is antisymmetric and v is symmetric about the equator.
    !            in this case the vorticity is symmetyric about the
    !            equator and is computed for the northern hemisphere
    !            only.  i.e., if nlat is odd the vorticity is computed
    !            in the array vort(i, j) for i=1, ..., (nlat + 1)/2 and for
    !            j=1, ..., nlon.  if nlat is even the vorticity is computed
    !            in the array vort(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !      = 2
    !            w is symmetric and v is antisymmetric about the equator
    !            in this case the vorticity is antisymmetric about the
    !            equator and is computed for the northern hemisphere
    !            only.  i.e., if nlat is odd the vorticity is computed
    !            in the array vort(i, j) for i=1, ..., (nlat + 1)/2 and for
    !            j=1, ..., nlon.  if nlat is even the vorticity is computed
    !            in the array vort(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !      nt    nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            in the program that calls vrtgc, the arrays cr, ci, and vort
    !            can be three dimensional corresponding to an indexed multiple
    !            vector field.  in this case multiple scalar synthesis will
    !            be performed to compute the vorticity for each field.  the
    !            third index is the synthesis index which assumes the values
    !            k=1, ..., nt.  for a single synthesis set nt = 1.  the
    !            description of the remaining parameters is simplified by
    !            assuming that nt=1 or that all the arrays are two dimensional.
    !
    !     ivrt   the first dimension of the array vort as it appears in
    !            the program that calls vrtgc. if isym = 0 then ivrt
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then ivrt must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then ivrt must be at least (nlat + 1)/2.
    !
    !     jvrt   the second dimension of the array vort as it appears in
    !            the program that calls vrtgc. jvrt must be at least nlon.
    !
    !    cr, ci   two or three dimensional arrays (see input parameter nt)
    !            that contain vector spherical harmonic coefficients
    !            of the vector field (v, w) as computed by subroutine vhagc.
    !     ***    cr and ci must be computed by vhagc prior to calling
    !            vrtgc.
    !
    !      mdc   the first dimension of the arrays cr and ci as it
    !            appears in the program that calls vrtgc. mdc must be at
    !            least min(nlat, nlon/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !      ndc   the second dimension of the arrays cr and ci as it
    !            appears in the program that calls vrtgc. ndc must be at
    !            least nlat.
    !
    !   wshsgc   an array which must be initialized by subroutine shsgci.
    !            once initialized,
    !            wshsgc can be used repeatedly by vrtgc as long as nlon
    !            and nlat remain unchanged.  wshsgc must not be altered
    !            between calls of vrtgc
    !
    !   lshsgc   the dimension of the array wshsgc   as it appears in the
    !            program that calls vrtgc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgc must be at least
    !
    !               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !
    !     vort   a two or three dimensional array (see input parameter nt)
    !            that contains the vorticity of the vector field (v, w)
    !            whose coefficients cr, ci where computed by subroutine vhagc.
    !            vort(i, j) is the vorticity at the gaussian colatitude point
    !            theta(i) and longitude point lambda(j) = (j-1)*2*pi/nlon.
    !            the index ranges are defined above at the input parameter
    !            isym.
    !
    !
    !   ierror   an error parameter which indicates fatal errors with input
    !            parameters when returned positive.
    !          = 0  no errors
    !          = 1  error in the specification of nlat
    !          = 2  error in the specification of nlon
    !          = 3  error in the specification of isym
    !          = 4  error in the specification of nt
    !          = 5  error in the specification of ivrt
    !          = 6  error in the specification of jvrt
    !          = 7  error in the specification of mdc
    !          = 8  error in the specification of ndc
    !          = 9  error in the specification of lshsgc
    !
    module subroutine vrtgc(nlat, nlon, isym, nt, vort, ivrt, jvrt, &
        cr, ci, mdc, ndc, wshsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: vort(ivrt, jvrt, nt)
        integer(ip), intent(in)  :: ivrt
        integer(ip), intent(in)  :: jvrt
        real(wp),    intent(in)  :: cr(mdc, ndc, nt)
        real(wp),    intent(in)  :: ci(mdc, ndc, nt)
        integer(ip), intent(in)  :: mdc
        integer(ip), intent(in)  :: ndc
        real(wp),    intent(in)  :: wshsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)                  :: required_wavetable_size
        type(ScalarSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsgc(nlat, nlon)

        call util%check_vector_transform_inputs(isym, ivrt, jvrt, &
            mdc, ndc, nlat, nlon, nt, required_wavetable_size, &
            wshsgc, ierror)

        ! Check error flag
        if (ierror /= 0) return

        call vorticity_lower_utility_routine(nlat, nlon, isym, nt, vort, &
            cr, ci, wshsgc, shsgc, ierror)

    end subroutine vrtgc

end submodule vorticity_gaussian_grid


SUBROUTINE random_wave_signal(i_spec, nt, nx, x0, x, dt, Tp, Hs, depth, &
     grav, inc_wave_file, kh_max, seed, seed2, eta, phiS, eta0, n_cut, time0)
  !-----------------------------------------------------------------------
  !
  ! Generate a pseudo-random long crested wave with direction beta to the
  ! x-axis, over NT time steps at NX points over the 1D computational
  ! free-surface which has a total of NF points.
  ! The x-positions of the points in the wave generation zone are given by x(1:nx)
  ! and the time-step dt is uniform.  The water depth at the wavemaker (x0)
  ! is depth.  The wave can be based on a P-M (i_spec=0) or JONSWAP (ispec=1)
  ! spectrum, or an input time series read from inc_wave_file (i_spec=2).
  ! The wave is moved around in space using linear theory in the frequency
  ! domain.  eta & phiS are returned with the time series
  ! of elevation and potential at z=0 in the wavemaker zone (j=1,nx).
  ! etat0 & phiSt0 hold the initial conditions over the entire domain for the P-M or
  ! JONSWAP case but not for an input wave (this is not implemented yet !HBB).
  !
  ! When i_spec=-1, a mono-chromatic wave is generated with period Tp and
  ! height Hs.
  !
  !----------------------------------------------------------------------
  IMPLICIT none
  CHARACTER(len=30) inc_wave_file, header
  integer, parameter :: long=selected_real_kind(12,99)
  integer i_spec, seed, seed2, nt, nx, n_cut
  real(kind=long) :: Tp, Hs, dt, depth, time0, x0, grav
  real(kind=long) :: x(nx), phiS(nx,nt), eta(nx,nt), eta0(nt)

  ! Local variables
  INTEGER :: i, j
  real(kind=long) :: cosb, sinb, factor, domega, realpt, beta, dx,       &
       imagpt, spec, phase, nu, coslnu, sinlnu, magx2, x2(3), x1(2),     &
       kinf, omega, dist, realarg, imagarg, reala, imaga,                &
       zero=0._long,  one=1._long, two=2._long, pi,twopi,udum=1.0_long,  &
       velfact, tanhkhi, dt_inc, dum, kh_max, phifact, kh, t, amp
  !
  ! Local workspace
  !
  real(kind=long),Allocatable :: work_eta(:), work_vel(:)
  allocate( work_eta(nt), work_vel(nt) )
  !
  !
  ! Some parameters
  !
  pi=acos(-one)
  twopi=two*pi
  !
  IF(i_spec >= 0)THEN
     !
     ! Generate the random wave.
     !
     ! The FT factor.
     !
     factor = two/nt
     !
     ! The Fourier coefficients are built based on SI dimensional numbers.  Omega is
     ! radian frequency.
     !
     domega = twopi / (nt * dt)
     !
     ! Only waves in the x-direction are implemented at this point -hbb
     !
     beta=zero
     cosb = cos (beta )
     sinb = sin (beta )
     !
     !
     ! Translate the Fourier amplitudes around in space to generate the
     ! eta and phiS coefficients over some portion of the free-surface.
     !
     DO j = 1, nx
        !
        ! Compute the distance (dist) from the origin of the coordinates (x0) to
        ! the point where the wave elevation is to be obtained, measured along
        ! the direction of wave propogation.
        !
        x1 (1) = cos (beta)
        x1 (2) = sin (beta)
        x2 (1) = x(j)-x0
        x2 (2) = zero
        !
        ! Beta is the angle between the (positive sense of the) incident wave
        ! vector and the (positive sense of the) (x,y) point vector.
        !
        dist = x1 (1) * x2 (1) + x1 (2) * x2 (2)
        !
        ! Take care of omega=0 and  the Nyquist frequency.
        !
        work_eta(1) = zero
        work_eta(2) = zero
        work_vel(1) = zero
        work_vel(2) = zero
        !
        ! The rest of frequency space.
        !
        DO i = 2, n_cut
           omega = (i - 1) * domega
           kinf = omega * omega / grav
           IF (depth.gt.zero) then
              ! Calling this routine with udum=1. gives the SI dimensional wavenumber.
              CALL fdwvnum (depth, omega, kinf, udum, grav, nu)
           ELSE
              nu = kinf
           ENDIF
           !
           ! Multiply each Fourier coefficient
           ! by e^-i*nu*l to shift it to the point (x,y).  The coefficients are defined
           ! such that eta(t) = Re B(omega) e^(omega t - k theta).
           !
           if(nu*depth > 15.0)then
              ! this wave component is in infinite depth (to double-precision).
              velfact = omega
           else
              ! this wave component is in finite depth.
              tanhkhi = cosh(nu*depth)/sinh(nu*depth)
              velfact = omega * tanhkhi
           end if
           phifact=grav/omega
           !
           coslnu = cos (nu * dist)
           sinlnu = sin (nu * dist)
           reala = eta0(2*i-1)
           imaga = eta0(2*i)
           realarg = (reala * coslnu - imaga * sinlnu)
           imagarg = (coslnu * imaga + sinlnu * reala)
           work_eta(2*i-1) = realarg
           work_eta(2*i) = imagarg
           !
           ! The horizontal surface velocity
           !
           !        work_vel(2*i-1) = x1(1) * velfact * realarg
           !        work_vel(2*i) =  x1(1) * velfact * imagarg
           !
           ! The surface velocity potential
           !
           work_vel(2*i-1) = phifact * imagarg
           work_vel(2*i) =  -phifact * realarg
        enddo
        do i=n_cut+1,nt/2
           work_eta(2*i-1)=zero
           work_eta(2*i) = zero
           work_vel(2*i-1) = zero
           work_vel(2*i) =  zero
        end do
        ! Inverse transform to get the time-series at this j-point.
        CALL drealft (work_eta, nt, -1)
        CALL drealft (work_vel, nt, -1)
        eta(j,:)=work_eta(:)
        phiS(j,:)=work_vel(:)
     enddo
  ELSE
     !
     ! For the monochromatic case things are much simpler.
     !
     omega=twopi/Tp
     kinf=omega**2/grav;
     ! Get the wavenumber nu
     CALL fdwvnum(depth,omega,kinf,one,grav,nu)
     amp=Hs/two
     phifact=grav/omega
     !
     do i=1,nt
        t=time0+(i-1)*dt
        eta0(i)=amp*cos(-omega*t)
        do j=1,nx
           dist=x(j)-x0
           eta(j,i)=amp*cos(nu*dist-omega*t)
           phiS(j,i)=phifact*amp*sin(nu*dist-omega*t)
        end do
     end do
     !
     !  Write the wavemaker signal.
     !
     open(21,file='eta0_irregular',status='unknown')
     write(21,36)Hs,Tp,depth
36      format('% Mono-chromatic wave with H=',e12.4,' T=',e12.4,' at x=',e12.4,'.')
     do i=1,nt
        write(21,*)(i-1)*dt,eta0(i)
     end do
     close(21)
  END IF

  DEALLOCATE(work_eta, work_vel)
444 FORMAT ()
445 FORMAT(3e12.5)
  RETURN
END SUBROUTINE random_wave_signal


!-----------------------------------------------------------------------------------
!-----------------------------------------------------------------------------------
!-----------------------BIVARIATE B-SPLINE EVALUATION ROUTINE-----------------------
!-----------------------------------------------------------------------------------
!--------------------------------Benjamin D. Donovan--------------------------------
!-----------------------------------------------------------------------------------
!-----------------------------------------------------------------------------------
!
!
!-----------------------------------------------------------------------------------
!BIVARIATEBSPLINEEV
!
!A subroutine to return the value of the interpolation at the coordinate (x,y).
!
!Parameters:
!-----------
!x : The x-coordinate of the point of interest.
!y : The y-coordinate of the point of interest.
!u : The knot vector for the x variable.
!      Comes from scipy.interpolate.SmoothBivariateSpline().get_knots()
!v : The knot vector for the y variable.
!      Comes from scipy.interpolate.SmoothBivariateSpline().get_knots()
!coeff : The 4x4 array of the coefficients.
!      Comes from scipy.interpolate.SmoothBivariateSpline().get_coeffs()
!dx : The derivative with respect to x.
!dy : The derivative with respect to y.
!summ : The z-value at the coordinate (x,y).
!
!Notes:
!------
!1. For interfacing with scipy.interpolate.SmoothBivariateSpline, the array of
!   coefficients must be reshaped from a 1D array with 16 elements to a 2D with
!   4 rows and 4 columns.
!2. If you make the value of 'dx' or 'dy' anything other than 0 or 1, your value
!   from the subroutine will be zero.
!3. Information on the summation performed in this subroutine can be found at:
!   http://www.cs.mtu.edu/~shene/COURSES/cs3621/NOTES/surface/bspline-construct.html
!-----------------------------------------------------------------------------------

subroutine bivariateBSplineEv(x, y, u, v, coeff, dx, dy, summ)

  !Declaration of all variables used in the subroutine.
  implicit none
  real, intent(in) :: x, y
  real, dimension(0:7) :: u, v
  integer, intent(in) :: dx, dy
  real, dimension(0:3,0:3) :: coeff
  integer :: i, j
  real :: bSplineBasisDerivative, bSplineBasisFcn
  real, intent(out) :: summ

  !Define the summ value to be zero.
  summ = 0.

  !Perform the summation. Information about the summation can be found in the link above.
  do i=0,3
    do j=0,3
      if ((dx==0) .and. (dy==0)) then
        summ = summ + bSplineBasisFcn(i, 3, u, x) * bSplineBasisFcn(j, 3, v, y) * coeff(i, j)
      else if ((dx==1) .and. (dy==0)) then
        summ = summ + bSplineBasisDerivative(i, 3, u, x) * bSplineBasisFcn(j, 3, v, y) * coeff(i, j)
      else if ((dx==0) .and. (dy==1)) then
        summ = summ + bSplineBasisFcn(i, 3, u, x) * bSplineBasisDerivative(j, 3, v, y) * coeff(i, j)
      end if
    end do
  end do

end subroutine bivariateBSplineEv

!-----------------------------------------------------------------------------------
!BSPLINEBASISDERIVATIVE
!
!A recursive function to evaluate the derivative of the i-th B-spline basis function
!of degree p.
!
!Parameters:
!-----------
!i : The i-th B-spline basis function to evaluate.
!p : The degree of the i-th B-spline basis function.
!u : The array of knots.
!x : Point at which to evalute the i-th B-spline basis function derivative of
!    of degree p.
!
!Results:
!--------
!bSBFD : Value of the specified B-spline basis function derivative at x.
!-----------------------------------------------------------------------------------

recursive function bSplineBasisDerivative(i, p, u, x) result(bSBFD)

  !Declaration of variables used in the recursive function.
  implicit none
  integer :: i, p
  real, intent(in) :: x
  real, dimension(0:7) :: u
  real :: c, d, e, f, bSBFD1, bSBFD2, bSBFD, bSplineBasisFcn

  !If the degree of the B-spline basis function equals zero, the derivative of the
  !B-spline basis function is zero.
  if (p .eq. 0) then
    bSBFD = 0.

  !Otherwise, the value needs to be calculated.
  else
    if (u(i+p) - u(i) .eq. 0.) then
      c = 0.
      d = 0.
    else
      c = 1/(u(i+p) - u(i))
      d = (x - u(i))/(u(i+p)-u(i))
    end if

    if (u(i+p+1) - u(i+1) .eq. 0.) then
      e = 0.
      f = 0.
    else
      e = 1/(u(i+p+1) - u(i+1))
      f = (u(i+p+1) - x)/(u(i+p+1) - u(i+1))
    end if

    !Recursive calculation of the B-spline basis function derivative.
    bSBFD1 = c * bSplineBasisFcn(i,p-1,u,x) + d * bSplineBasisDerivative(i,p-1,u,x)
    bSBFD2 = -e * bSplineBasisFcn(i+1,p-1,u,x) + f * bSplineBasisDerivative(i+1,p-1,u,x)
    bSBFD = bSBFD1 + bSBFD2
  end if

end function bSplineBasisDerivative

!-----------------------------------------------------------------------------------
!BSPLINEBASISFCN
!
!A recursive function to evaluate i-th B-spline basis function of degree p.
!
!Parameters:
!-----------
!i : The i-th B-spline basis function to evaluate.
!p : The degree of the i-th B-spline basis function.
!u : The array of knots.
!z : Point at which to evalute the i-th B-spline basis function derivative of
!    of degree p.
!
!Results:
!--------
!bSBF : Value of the specified B-spline basis function derivative at x.
!-----------------------------------------------------------------------------------
recursive function bSplineBasisFcn(i, p, u, z) result(bSBF)

  !Declaration of variables used in the recursive function.
  implicit none
  integer :: i, p
  real, intent(in) :: z
  real, dimension(0:7) :: u
  real :: a, b, bSBF

  !If the degree of the basis function is zero, the basis function is zero or one,
  !depending on whether or not z is between the i-th and the i-th + 1 knot.
  if (p .eq. 0) then
    if (u(i) .le. z .and. z .lt. u(i+1)) then
      bSBF = 1.
    else
      bSBF = 0.
    end if

  !If the degree of the basis function is not zero, it must be calculated.
  else
    if (u(i+p) - u(i) .eq. 0.) then
      a = 0
    else
      a = (z - u(i))/(u(i+p)-u(i))
    end if

  if (u(i+p+1) - u(i+1) .eq. 0.) then
    b = 0
  else
    b = (u(i+p+1) - z)/(u(i+p+1) - u(i+1))
  end if

  !Recursive calculation of the B-spline basis function.
  bSBF = a * bSplineBasisFcn(i, p-1, u, z) + b * bSplineBasisFcn(i+1, p-1, u, z)
  end if

end function bSplineBasisFcn