PROGRAM dot_product
  IMPLICIT NONE

  ! Precision constants
  INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(14,100) ! 64-bit (double)

  ! Vector dimension
  INTEGER :: N

  ! Loop index
  INTEGER :: i

  ! Vectors to take the dot product with
  REAL(KIND=dp), DIMENSION(:), ALLOCATABLE :: vecA, vecB

  ! Result and check value
  REAL(KIND=dp) :: result, check

  ! Tolerance for error checking
  REAL(KIND=dp), PARAMETER :: tol = 10._dp**(-10)

  ! Timing subroutine
  INTRINSIC :: DATE_AND_TIME

  ! Timing vars
  INTEGER, DIMENSION(8) :: t0, t1, t2
  REAL(KIND=dp) :: time_init, time_ddot

  ! argc, argv (Fortran 2003)
  INTRINSIC :: COMMAND_ARGUMENT_COUNT, GET_COMMAND_ARGUMENT
  INTEGER :: argc
  CHARACTER(LEN=8) :: argv ! We only need one

  ! Check argc
  IF( COMMAND_ARGUMENT_COUNT() > 0 ) THEN

     ! Read n from argv[1]
     CALL GET_COMMAND_ARGUMENT( 1, VALUE=argv )
     READ( argv, * ) n

  ELSE

     ! Read n from standard input
     WRITE(*,*) 'Input vector length n:'
     READ(*,*) n

  END IF

  ! Echo n to standard output
  WRITE(*,*) 'Using n = ', n

  CALL DATE_AND_TIME( values=t0 )

  ! Allocate vectors on CPU
  ALLOCATE( vecA(n) )
  ALLOCATE( vecB(n) )

  ! Allocate vectors and result variable on device (GPU)
  !$ACC DATA CREATE( vecA, vecB, result )

  ! Initialize vectors on device
  !$ACC PARALLEL LOOP PRESENT( vecA, vecB ) COPYIN( N )
  DO i = 1, N
     vecA(i) = REAL( i,   KIND=dp )
     vecB(i) = REAL( 2*i, KIND=dp )
  END DO ! i
  !$ACC END PARALLEL LOOP

  ! Initialize result variable
  !$ACC KERNELS PRESENT( result )
  result = 0._dp
  !$ACC END KERNELS

  ! Barrier to ensure initialization completes
  !$ACC WAIT

  CALL DATE_AND_TIME( values=t1 )

  ! Perform dot product on device
  !$ACC PARALLEL LOOP PRESENT( vecA, vecB, result ) COPYIN( N ) &
  !$ACC   REDUCTION(+:result)
  DO i = 1, N
     result = result + vecA(i) * vecB(i)
  END DO ! i
  !$ACC END PARALLEL LOOP

  CALL DATE_AND_TIME( values=t2 )

  ! Fetch result from device
  !$ACC UPDATE HOST( result )

  ! Check value ( using relative error ) and print result to standard output
  check = REAL( N, KIND=dp ) * REAL( N+1, KIND=dp ) * REAL( 2*N+1, KIND=dp) &
          / 3._dp
  IF( ABS( result/check - 1 ) > tol ) THEN
     WRITE(*,*) 'Error! Result = ', result, ' when it should be ', check
  ELSE
     WRITE(*,*) 'Success! Result = ', result
  END IF

  ! Calculate and display timers
  time_init = REAL( 3600*t1(5) + 60*t1(6) + t1(7), KIND=dp ) &
              + 0.001_dp*REAL( t1(8), KIND=dp ) &
              - REAL( 3600*t0(5) + 60*t0(6) + t0(7), KIND=dp ) &
              - 0.001_dp*REAL( t0(8), KIND=dp )
  time_ddot = REAL( 3600*t2(5) + 60*t2(6) + t2(7), KIND=dp ) &
              + 0.001_dp*REAL( t2(8), KIND=dp ) &
              - REAL( 3600*t1(5) + 60*t1(6) + t1(7), KIND=dp ) &
              - 0.001_dp*REAL( t1(8), KIND=dp )
  WRITE(*,'(A,F8.3,A)') 'Initialization took ', time_init, ' seconds.'
  WRITE(*,'(A,F8.3,A)') 'Computation took ', time_ddot, ' seconds.'

  ! Clean up
  !$ACC END DATA
  DEALLOCATE( vecA )
  DEALLOCATE( vecB )

  STOP
END PROGRAM dot_product


! { dg-do compile }
! Check the fix for PR30879, in which the structure
! components in the DATA values would cause a syntax
! error.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
  TYPE T1
   INTEGER :: I
  END TYPE T1

  TYPE(T1), PARAMETER :: D1=T1(2)
  TYPE(T1) :: D2(2)

  INTEGER :: a(2)

  DATA (a(i),i=1,D1%I) /D1%I*D1%I/

  DATA (D2(i),i=1,D1%I) /D1%I*T1(4)/

  print *, a
  print *, D2
  END


! Check that parameters are correct intercepted.
! Specifically that types of constants without
! compound kind specs are correctly inferred
! adapted Gibbs iteration code from pymc
! for this test case
subroutine foo_non_compound_int(x)
  implicit none
  integer, parameter :: ii = selected_int_kind(9)

  integer(ii)   maxiterates
  parameter (maxiterates=2)

  integer(ii)   maxseries
  parameter (maxseries=2)

  integer(ii)   wasize
  parameter (wasize=maxiterates*maxseries)
  integer(ii), intent(inout) :: x
  dimension x(wasize)

  x(1) = x(1) + x(2) + x(3) + x(4) * wasize
  return
end subroutine


submodule (m_Select) sm_quickselect
  !! quickselect and argQuickselect routines

  use m_swap, only: swap
  use m_random, only: rngInteger
  use m_partition, only: partition, argPartition
  use m_medianOf3, only: medianOf3, argMedianOf3
  use m_sort, only: insertionSort, argInsertionSort
  implicit none

  contains
  !====================================================================!
  module procedure quickSelect_r1D
    !! Interfaced with quickselect()
  !====================================================================!
  !real(r32), intent(inout) :: this(:) !! 1D array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !real(r32) :: res !! kth element
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid
  integer(i32) :: N

  lo = 1
  hi = size(this)

  do while (hi >= lo)
    if (hi - lo < 17) then
      call insertionSort(this, lo, hi)
      res = this(k)
      return
    end if
    mid = (hi+lo)/2
    call medianOf3(this, lo, mid, hi)
    call swap(this(lo), this(mid))
    call partition(this, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = this(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure quickSelect_d1D !(this, k) result(res)
    !! Interfaced with quickselect()
  !====================================================================!
  !real(r64), intent(inout) :: this(:) !! 1D array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !real(r64) :: res !! kth element
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(this)

  do while (hi >= lo)
    if (hi - lo < 17) then
      call insertionSort(this, lo, hi)
      res = this(k)
      return
    end if
    mid = (hi+lo)/2
    call medianOf3(this, lo, mid, hi)
    call swap(this(lo), this(mid))
    call partition(this, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = this(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure quickSelect_i1D !(this, k) result(res)
    !! Interfaced with quickselect()
  !====================================================================!
  !integer(i32), intent(inout) :: this(:) !! 1D array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i32) :: res !! kth element
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(this)

  do while (hi >= lo)
    if (hi - lo < 17) then
      call insertionSort(this, lo, hi)
      res = this(k)
      return
    end if
    mid = (hi+lo)/2
    call medianOf3(this, lo, mid, hi)
    call swap(this(lo), this(mid))
    j = mid
    call partition(this, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = this(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure quickSelect_id1D !(this, k) result(res)
    !! Interfaced with quickselect()
  !====================================================================!
  !integer(i64), intent(inout) :: this(:) !! 1D array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i64) :: res !! kth element
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(this)

  do while (hi >= lo)
    if (hi - lo < 17) then
      call insertionSort(this, lo, hi)
      res = this(k)
      return
    end if
    mid = (hi+lo)/2
    call medianOf3(this, lo, mid, hi)
    call swap(this(lo), this(mid))
    call partition(this, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = this(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure argQuickselect_r1D !(this, indx, k, left, right) result(res)
    !! Interfaced with argQuickselect()
  !====================================================================!
  !real(r32), intent(in) :: this(:) !! 1D array
  !integer(i32), intent(inout) :: indx(:) !! Index into array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i32) :: res !! kth index
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(indx)
  if (present(left)) lo = left
  if (present(right)) hi = right

  res = -1

  do while (hi >= lo)
    if (hi - lo < 17) then
      call argInsertionSort(this, indx, lo, hi)
      res = indx(k)
      return
    end if
    mid = (hi+lo)/2
    call argMedianOf3(this, indx, lo, mid, hi)
    call swap(indx(lo), indx(mid))
    call argPartition(this, indx, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = indx(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure argQuickselect_d1D
    !! Interfaced with argQuickselect()
  !====================================================================!
  !real(r64), intent(in) :: this(:) !! 1D array
  !integer(i32), intent(inout) :: indx(:) !! Index into array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i32) :: res !! kth index
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(indx)
  if (present(left)) lo = left
  if (present(right)) hi = right

  res = -1

  do while (hi >= lo)
    if (hi - lo < 17) then
      call argInsertionSort(this, indx, lo, hi)
      res = indx(k)
      return
    end if
    mid = (hi+lo)/2
    call argMedianOf3(this, indx, lo, mid, hi)
    call swap(indx(lo), indx(mid))
    call argPartition(this, indx, lo, hi, j)

    ! Found the kth value, exit
    if (j == k) then
      res = indx(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure argQuickselect_i1D !(this, indx, k, left, right) result(res)
    !! Interfaced with argQuickselect()
  !====================================================================!
  !integer(i32), intent(in) :: this(:) !! 1D array
  !integer(i32), intent(inout) :: indx(:) !! Index into array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i32) :: res !! kth index
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(indx)
  if (present(left)) lo = left
  if (present(right)) hi = right

  res = -1

  do while (hi >= lo)
    if (hi - lo < 17) then
      call argInsertionSort(this, indx, lo, hi)
      res = indx(k)
      return
    end if
    mid = (hi+lo)/2
    call argMedianOf3(this, indx, lo, mid, hi)
    call swap(indx(lo), indx(mid))
    call argPartition(this, indx, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = indx(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure argQuickselect_id1D !(this, indx, k, left, right) result(res)
    !! Interfaced with argQuickselect()
  !====================================================================!
  !integer(i64), intent(in) :: this(:) !! 1D array
  !integer(i32), intent(inout) :: indx(:) !! Index into array
  !integer(i32), intent(in) :: k !! kth smallest element to find
  !integer(i32) :: res !! kth index
  integer(i32) :: hi
  integer(i32) :: j
  integer(i32) :: lo
  integer(i32) :: mid

  lo = 1
  hi = size(indx)
  if (present(left)) lo = left
  if (present(right)) hi = right

  res = -1

  do while (hi >= lo)
    if (hi - lo < 17) then
      call argInsertionSort(this, indx, lo, hi)
      res = indx(k)
      return
    end if
    mid = (hi+lo)/2
    call argMedianOf3(this, indx, lo, mid, hi)
    call swap(indx(lo), indx(mid))
    call argPartition(this, indx, lo, hi, j)
    ! Found the kth value, exit
    if (j == k) then
      res = indx(k)
      return
    end if
    if (j < k) then
      lo = j + 1
    elseif (j > k) then
      hi = j - 1
    end if
  end do
  end procedure
  !====================================================================!
end submodule


! input   : [[1], 2, [[3, 4], 5], [[[]]], [[[6]]], 7, 8, []]
! flatten : [1, 2, 3, 4, 5, 6, 7, 8 ]

module flat
  implicit none

  type n
     integer                             :: a
     type(n), dimension(:), pointer      :: p => null()
     logical                             :: empty = .false.
  end type

contains

  recursive subroutine del(this)
  type(n), intent(inout) :: this
  integer                :: i
  if (associated(this%p)) then
    do i = 1, size(this%p)
       call del(this%p(i))
    end do
  end if
  end subroutine

  function join(xs) result (r)
  type(n), dimension(:), target :: xs
  type(n)                       :: r
  integer                       :: i
  if (size(xs)>0) then
    allocate(r%p(size(xs)), source=xs)
    do i = 1, size(xs)
      r%p(i) = xs(i)
    end do
  else
    r%empty = .true.
  end if
  end function

  recursive subroutine flatten1(x,r)
  integer, dimension (:), allocatable, intent(inout) :: r
  type(n), intent(in)                                :: x
  integer, dimension (:), allocatable                :: tmp
  integer                                            :: i
  if (associated(x%p)) then
    do i = 1, size(x%p)
      call flatten1(x%p(i), r)
    end do
  elseif (.not. x%empty) then
    allocate(tmp(size(r)+1))
    tmp(1:size(r)) = r
    tmp(size(r)+1) = x%a
    call move_alloc(tmp, r)
  end if
  end subroutine

  function flatten(x) result (r)
  type(n), intent(in)                                :: x
  integer, dimension(:), allocatable                 :: r
  allocate(r(0))
  call flatten1(x,r)
  end function

  recursive subroutine show(x)
  type(n)   :: x
  integer   :: i
  if (x%empty) then
    write (*, "(a)", advance="no") "[]"
  elseif (associated(x%p)) then
    write (*, "(a)", advance="no") "["
    do i = 1, size(x%p)
      call show(x%p(i))
      if (i<size(x%p)) then
        write (*, "(a)", advance="no") ", "
      end if
    end do
    write (*, "(a)", advance="no") "]"
  else
    write (*, "(g0)", advance="no") x%a
  end if
  end subroutine

  function fromString(line) result (r)
  character(len=*)                      :: line
  type (n)                              :: r
  type (n), dimension(:), allocatable   :: buffer, buffer1
  integer, dimension(:), allocatable    :: stack, stack1
  integer                               :: sp,i0,i,j, a, cur, start
  character                             :: c

  if (.not. allocated(buffer)) then
    allocate (buffer(5)) ! will be re-allocated if more is needed
  end if
  if (.not. allocated(stack)) then
    allocate (stack(5))
  end if

  sp = 1; cur = 1; i = 1
  do
    if ( i > len_trim(line) ) exit
    c = line(i:i)
    if (c=="[") then
      if (sp>size(stack)) then
        allocate(stack1(2*size(stack)))
        stack1(1:size(stack)) = stack
        call move_alloc(stack1, stack)
      end if
      stack(sp) = cur;  sp = sp + 1; i = i+1
    elseif (c=="]") then
      sp = sp - 1; start = stack(sp)
      r = join(buffer(start:cur-1))
      do j = start, cur-1
        call del(buffer(j))
      end do
      buffer(start) = r; cur = start+1; i = i+1
    elseif (index(" ,",c)>0) then
      i = i + 1; continue
    elseif (index("-123456789",c)>0) then
      i0 = i
      do
        if ((i>len_trim(line)).or. &
            index("1234567890",line(i:i))==0) then
          read(line(i0:i-1),*) a
          if (cur>size(buffer)) then
            allocate(buffer1(2*size(buffer)))
            buffer1(1:size(buffer)) = buffer
            call move_alloc(buffer1, buffer)
          end if
          buffer(cur) = n(a); cur = cur + 1; exit
        else
          i = i+1
        end if
      end do
    else
       stop "input corrupted"
    end if
  end do
  end function
end module

program main
  use flat
  type (n)  :: x
  x = fromString("[[1], 2, [[3,4], 5], [[[]]], [[[6]]], 7, 8, []]")
  write(*, "(a)", advance="no") "input   : "
  call show(x)
  print *
  write (*,"(a)", advance="no") "flatten : ["
  write (*, "(*(i0,:,:', '))", advance="no") flatten(x)
  print *, "]"
end program


!
! wrappers for gaussinte_mod.f90
!

subroutine f90_gaussinte_w(n, x, w, eps)
  use gaussinte
  integer, intent(in) :: n
  double precision, intent(out) :: x(1:n), w(1:n)
  double precision, intent(in) :: eps

  call gaussinte_w(n, x, w, eps)
end subroutine f90_gaussinte_w

function f90_gaussinte_fx(n, x, a, b, fx) result(c)
  use gaussinte
  integer, intent(in) :: n
  double precision, intent(in) :: x(1:n), a, b
  double precision, intent(out) :: fx(1:n)
  double precision :: c
  c = gaussinte_fx(n, x, a, b, fx)
end function f90_gaussinte_fx

function f90_gaussinte_fv(n, w, c, fv) result(s)
  use gaussinte
  integer, intent(in) :: n
  double precision, intent(in) :: w(1:n), c, fv(1:n)
  double precision :: s
  s = gaussinte_fv(n, w, c, fv)
end function f90_gaussinte_fv


submodule(euler_interface_m) euler_prob_0032_m
    implicit none

contains

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

    integer(int64) function ans()
        integer(int64) :: temp, i, j, k, arr_of_prods(9)
        integer(int64), allocatable :: arr_of_nonrepeats(:)

        k = 1
        do i = 1, 9
            do j = 1234, 9876
                if (digs_of_int(i*j) > 4) cycle
                temp = i*10**8 + j*10**4 + i*j

                if (is_pandigital(temp, digs_of_int(temp))) then
                    arr_of_prods(k) = i*j
                    k = k + 1
                end if
            end do
        end do

        do i = 12, 98
            do j = 123, 987
                if (digs_of_int(i*j) > 4) cycle
                temp = i*10**7 + j*10**4 + i*j
                if (is_pandigital(temp, digs_of_int(temp))) then
                    arr_of_prods(k) = i*j
                    k = k + 1
                end if
            end do
        end do

        call remove_duplicates(arr_of_prods, arr_of_nonrepeats)
        ans = sum(arr_of_nonrepeats, dim=1)
    end function ans

    subroutine remove_duplicates(i_arr, o_arr)
        integer(int64), intent(in) :: i_arr(:)
        integer(int64), allocatable, intent(out) :: o_arr(:)
        integer(int64) :: i, k, tmp_arr(size(i_arr))

        tmp_arr = 0
        k = 1
        tmp_arr(1) = i_arr(1)

        do i = 2, size(i_arr)
            if (any(tmp_arr == i_arr(i))) cycle
            k = k + 1
            tmp_arr(k) = i_arr(i)
        end do

        allocate (o_arr(k))
        o_arr(:) = tmp_arr(1:k)
    end subroutine remove_duplicates

end submodule euler_prob_0032_m


program exceptions
    use, intrinsic :: ieee_arithmetic
    implicit none
    logical :: halting_mode, stat
    logical, dimension(size(IEEE_USUAL)) :: stats
    real :: r

    ! show values of halting mode for IEEE exceptions
    call ieee_get_halting_mode(IEEE_DIVIDE_BY_ZERO, halting_mode)
    print '(A, L)', 'divide by zero halting mode: ', halting_mode
    call ieee_get_halting_mode(IEEE_INVALID, halting_mode)
    print '(A, L)', 'invalid halting mode: ', halting_mode
    call ieee_get_halting_mode(IEEE_OVERFLOW, halting_mode)
    print '(A, L)', 'overflow halting mode: ', halting_mode

    ! check the value of the the IEEE_INVALID
    call ieee_get_flag(IEEE_INVALID, stat)
    print '(A, L)', 'invalig flag = ', stat

    ! illustrate that the halting mode is .false. by default
    ! Note that the compiler will detect that the square root of a negative
    ! number results in NaN, so we outsmart it using a random number.
    call random_number(r)
    print '(A, F15.7)', 'sqrt(-1.0) = ', sqrt(r-1.0)

    ! check the value of the the IEEE_INVALID
    call ieee_get_flag(IEEE_INVALID, stat)
    print '(A, L)', 'invalig flag = ', stat

    ! check the usual suspects
    call ieee_get_flag(IEEE_USUAL, stats)
    print '(A, L)', 'usual flags = ', any(stats)

    ! set the halting mode for IEEE_INVALID to .true. and redo the computation
    ! it will crash this time
    call ieee_set_halting_mode(ieee_invalid, .true.)
    call ieee_get_halting_mode(ieee_invalid, halting_mode)
    print '(A, L)', 'invalid halting mode: ', halting_mode
    print '(A, F15.7)', 'sqrt(-1.0) = ', sqrt(r-1.0)
end program exceptions


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> This module provides function to check input data of shell elements
module m_precheck_LIB_shell
contains
  !***********************************************************************
  !  SHELL Element:
  !  PRE_731( XX,YY,ZZ,thick,vol,almax,almin )
  !  PRE_741( XX,YY,ZZ,thick,vol,almax,almin )
  !----------------------------------------------------------------------*
  subroutine PRE_731( XX,YY,ZZ,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !**
    !**  Precheck for 3nodes SHELL
    !**
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),thick,vol,almax,almin
    ! LOCAL VARIABLES
    real(kind=kreal) V1X,V1Y,V1Z
    real(kind=kreal) V2X,V2Y,V2Z
    real(kind=kreal) V3X,V3Y,V3Z
    real(kind=kreal) area,a1,a2,a3
    area = 0.0
    vol = 0.0
    !** FACE 1-2-3
    V1X=XX(2)-XX(1)
    V1Y=YY(2)-YY(1)
    V1Z=ZZ(2)-ZZ(1)
    V2X=XX(3)-XX(1)
    V2Y=YY(3)-YY(1)
    V2Z=ZZ(3)-ZZ(1)
    V3X= V1Y*V2Z-V1Z*V2Y
    V3Y=-V1X*V2Z+V1Z*V2X
    V3Z= V1X*V2Y-V1Y*V2X
    area=sqrt( V3X*V3X + V3Y*V3Y + V3Z*V3Z )*0.5
    vol = area * thick
    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2+(zz(2)-zz(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2+(zz(3)-zz(2))**2 )
    a3 = sqrt( (xx(1)-xx(3))**2+(yy(1)-yy(3))**2+(zz(1)-zz(3))**2 )
    almax = dmax1( a1,a2,a3 )
    almin = dmin1( a1,a2,a3 )

  end subroutine PRE_731
  !----------------------------------------------------------------------*
  subroutine PRE_741( XX,YY,ZZ,thick,vol,almax,almin )
    !----------------------------------------------------------------------*
    !**
    !**  Precheck for 3nodes SHELL
    !**
    use hecmw
    use gauss_integration
    implicit none
    ! I/F VARIABLES
    real(kind=kreal) XX(*),YY(*),ZZ(*),thick,vol,almax,almin
    ! LOCAL VARIABLES
    integer(kind=kint) NN
    integer(kind=kint) NG
    parameter(NN=8,NG=2)
    real(kind=kreal) H(NN),HR(NN),HS(NN),HT(NN)
    real(kind=kreal) RI,SI,TI,RP,SP,TP,RM,SM,TM
    real(kind=kreal) XJ11,XJ21,XJ31,XJ12,XJ22,XJ32,XJ13,XJ23,XJ33,DET,WG
    integer(kind=kint) IG1,IG2,LX,LY,LZ,I
    real(kind=kreal) VX,VY,VZ,XCOD,YCOD,ZCOD
    real(kind=kreal) AX,AY,AZ,RX,RY,RZ,HX,HY,HZ,val
    real(kind=kreal) PHX,PHY,PHZ
    real(kind=kreal) G1X,G1Y,G1Z
    real(kind=kreal) G2X,G2Y,G2Z
    real(kind=kreal) G3X,G3Y,G3Z
    real(kind=kreal) XSUM,COEFX,COEFY,COEFZ
    real(kind=kreal) area,a1,a2,a3,a4
    !
    area = 0.0
    vol  = 0.0
    ! INTEGRATION OVER SURFACE
    do IG2=1,NG
      SI=XG(NG,IG2)
      do IG1=1,NG
        RI=XG(NG,IG1)
        H(1)=0.25*(1.0-RI)*(1.0-SI)
        H(2)=0.25*(1.0+RI)*(1.0-SI)
        H(3)=0.25*(1.0+RI)*(1.0+SI)
        H(4)=0.25*(1.0-RI)*(1.0+SI)
        HR(1)=-.25*(1.0-SI)
        HR(2)= .25*(1.0-SI)
        HR(3)= .25*(1.0+SI)
        HR(4)=-.25*(1.0+SI)
        HS(1)=-.25*(1.0-RI)
        HS(2)=-.25*(1.0+RI)
        HS(3)= .25*(1.0+RI)
        HS(4)= .25*(1.0-RI)
        G1X=0.0
        G1Y=0.0
        G1Z=0.0
        G2X=0.0
        G2Y=0.0
        G2Z=0.0
        do I=1,NN
          G1X=G1X+HR(I)*XX(I)
          G1Y=G1Y+HR(I)*YY(I)
          G1Z=G1Z+HR(I)*ZZ(I)
          G2X=G2X+HS(I)*XX(I)
          G2Y=G2Y+HS(I)*YY(I)
          G2Z=G2Z+HS(I)*ZZ(I)
        enddo
        G3X=G1Y*G2Z-G1Z*G2Y
        G3Y=G1Z*G2X-G1X*G2Z
        G3Z=G1X*G2Y-G1Y*G2X
        XSUM=dsqrt(G3X**2+G3Y**2+G3Z**2)
        G3X=G3X/XSUM
        G3Y=G3Y/XSUM
        G3Z=G3Z/XSUM
        !JACOBI MATRIX
        XJ11=G1X
        XJ12=G1Y
        XJ13=G1Z
        XJ21=G2X
        XJ22=G2Y
        XJ23=G2Z
        XJ31=G3X
        XJ32=G3Y
        XJ33=G3Z
        !DETERMINANT OF JACOBIAN
        DET=XJ11*XJ22*XJ33                                                 &
          +XJ12*XJ23*XJ31                                                 &
          +XJ13*XJ21*XJ32                                                 &
          -XJ13*XJ22*XJ31                                                 &
          -XJ12*XJ21*XJ33                                                 &
          -XJ11*XJ23*XJ32
        WG=WGT(NG,IG1)*WGT(NG,IG2)*DET
        do i = 1, NN
          area = area + H(i)*WG
        enddo
      enddo
    enddo

    vol = area*thick
    a1 = sqrt( (xx(2)-xx(1))**2+(yy(2)-yy(1))**2+(zz(2)-zz(1))**2 )
    a2 = sqrt( (xx(3)-xx(2))**2+(yy(3)-yy(2))**2+(zz(3)-zz(2))**2 )
    a3 = sqrt( (xx(4)-xx(3))**2+(yy(4)-yy(3))**2+(zz(4)-zz(3))**2 )
    a4 = sqrt( (xx(1)-xx(4))**2+(yy(1)-yy(4))**2+(zz(1)-zz(4))**2 )
    almax = dmax1( a1,a2,a3,a4 )
    almin = dmin1( a1,a2,a3,a4 )

  end subroutine PRE_741
end module m_precheck_LIB_shell


      subroutine rotate(x,y,psi)
C     subroutine    rotate    01/09/79
      ps=3.141593/180.*psi
      call atran2(cos(ps),-sin(ps),x*(1.-cos(ps))+y*sin(ps),
     csin(ps),cos(ps),-x*sin(ps)+y*(1.-cos(ps)))
      return
      end


    program main
    use mpi
    integer MAX_ROWS, MAX_COLS, rows, cols
    parameter (MAX_ROWS = 1000, MAX_COLS = 1000)
    double precision a(MAX_ROWS,MAX_COLS), b(MAX_COLS)
    double precision c(MAX_ROWS), buffer(MAX_COLS), ans

    integer myid, manager, numprocs, ierr, status(MPI_STATUS_SIZE)
    integer i, j, numsent, sender
    integer anstype, row

    call MPI_INIT(ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
    manager = 0
    rows   = 100
    cols   = 100

    if (myid .eq. manager) then
!     manager initializes and then dispatches
!     initialize a and b  (arbitrary)
       do j = 1,cols
          b(j) = 1
          do i = 1,rows
             a(i,j) = i
          enddo
       enddo
       numsent = 0
!     send b to each worker process
       call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, &
                      MPI_COMM_WORLD, ierr)
       !  send a row to each worker process; tag with row number
       do i = 1,min(numprocs-1,rows)
          do j = 1,cols
             buffer(j) = a(i,j)
          enddo
          call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, i, &
                        i, MPI_COMM_WORLD, ierr)
          numsent = numsent+1
       enddo
       do i = 1,rows
          call MPI_RECV(ans, 1, MPI_DOUBLE_PRECISION, &
                        MPI_ANY_SOURCE, MPI_ANY_TAG, &
                        MPI_COMM_WORLD, status, ierr)
          sender     = status(MPI_SOURCE)
          anstype    = status(MPI_TAG)       ! row is tag value
          c(anstype) = ans
          if (numsent .lt. rows) then        ! send another row
             do j = 1,cols
                buffer(j) = a(numsent+1,j)
             enddo
             call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, &
                           sender, numsent+1, MPI_COMM_WORLD, ierr)
             numsent = numsent+1
          else      ! Tell sender that there is no more work
             call MPI_SEND(MPI_BOTTOM, 0, MPI_DOUBLE_PRECISION, &
                  sender, 0, MPI_COMM_WORLD, ierr)
          endif
       enddo
       !        print out the answer
       do i = 1,cols
          print *, "c(", i, ") = ", c(i)
       enddo
    else
       !     workers receive b, then compute dot products until
       !     done message received
       call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, &
                      MPI_COMM_WORLD, ierr)
       if (myid .le. rows) then
          ! skip if more processes than work
          do
             call MPI_RECV(buffer, cols, MPI_DOUBLE_PRECISION, &
                           manager, MPI_ANY_TAG, MPI_COMM_WORLD, &
                           status, ierr)
             if (status(MPI_TAG) .eq. 0) exit
             row = status(MPI_TAG)
             ans = 0.0
             do i = 1,cols
                ans = ans+buffer(i)*b(i)
             enddo
             call MPI_SEND(ans, 1, MPI_DOUBLE_PRECISION, manager, &
                           row, MPI_COMM_WORLD, ierr)
          enddo
       endif
    endif

   call MPI_FINALIZE(ierr)
   end


!! R511 explicit-coshape-spec
!    is [ [ lower-cobound : ] upper-cobound, ]... [ lower-cobound : ] *
!
real :: A1[*]
real :: A2[3:*]
real :: A3[7,*]
real :: A4[2:7,5:*]
real :: A5[5,5,5,*]

end


module union_find_mod
    use,intrinsic :: iso_fortran_env
    private
    type,public:: union_find
        integer(int64),allocatable,private:: parent(:)
    contains
        procedure:: root => uf_root ! その要素の族を返す
        procedure:: is_family => uf_is_family ! 二つの要素が同族か判定
        procedure:: unite => uf_unite ! 二つの要素の族を融合
        procedure:: size => uf_size ! その要素の族の数を返す
    end type

    interface union_find
        module procedure:: uf_init
    end interface
contains
    function uf_init(n) result(uf)
        type(union_find):: uf
        integer(int64):: n,i

        allocate(uf%parent, source=[(-1_int64,i=1_int64,n)])
    end function

    recursive function uf_root(uf,x) result(ret)
        class(union_find):: uf
        integer(int64):: x,ret

        if (uf%parent(x) < 0) then
            ret = x
        else
            uf%parent(x) = uf%root(uf%parent(x))
            ret = uf%parent(x)
        end if
    end function

    function uf_is_family(uf,a,b)
        class(union_Find):: uf
        integer(int64),intent(in):: a,b
        logical:: uf_is_family

        uf_is_family = uf%root(a) == uf%root(b)
    end function

    subroutine uf_unite(uf,a,b)
        class(union_find):: uf
        integer(int64),intent(in):: a,b
        integer(int64):: ra, rb

        ra = uf%root(a); rb = uf%root(b)
        if (ra == rb) return
        if (uf%size(ra) < uf%size(rb)) call swap()
        uf%parent(ra) = uf%parent(ra) + uf%parent(rb)
        uf%parent(rb) = ra
        contains
            subroutine swap()
                ra = xor(ra,rb)
                rb = xor(ra,rb)
                ra = xor(ra,rb)
            end subroutine
    end subroutine

    function uf_size(uf,x)
        class(union_find):: uf
        integer(int64),intent(in):: x
        integer(int64):: uf_size

        uf_size = -uf%parent(uf%root(x))
    end function
end module


!! Useful subroutines to return exact solutions for various problems
!
! This file is part of LIBPFASST.
!
!> Module defining exact solutions for various PDEs
module pf_mod_solutions
  use pf_mod_dtype
  use pf_mod_stop
  implicit none

  interface exact_ad_cos
     module procedure exact_ad_cos_1d
     module procedure exact_ad_cos_1ds
     module procedure exact_ad_cos_1dz
     module procedure exact_ad_cos_2d
     module procedure exact_ad_cos_2dz
     module procedure exact_ad_cos_3d
     module procedure exact_ad_cos_3dz
  end interface exact_ad_cos
  interface exact_ad_exp
     module procedure exact_ad_exp_1d
     module procedure exact_ad_exp_1dz
     module procedure exact_ad_exp_2d
     module procedure exact_ad_exp_2dz
     module procedure exact_ad_exp_3d
     module procedure exact_ad_exp_3dz
  end interface exact_ad_exp
  interface exact_burg_sin
     module procedure exact_burg_sin_1d
     module procedure exact_burg_sin_1dz
     module procedure exact_burg_sin_2d
     module procedure exact_burg_sin_2dz
     module procedure exact_burg_sin_3d
     module procedure exact_burg_sin_3dz
  end interface exact_burg_sin
  interface exact_nls
     module procedure exact_nls_1dz
     module procedure exact_nls_2dz
     module procedure exact_nls_3dz
  end interface exact_nls
  interface exact_nls_sg
     module procedure exact_nls_sg_1dz
     module procedure exact_nls_sg_2dz
     module procedure exact_nls_sg_3dz
     module procedure exact_nls_sg_1d
     module procedure exact_nls_sg_2d
     module procedure exact_nls_sg_3d
  end interface exact_nls_sg
  interface exact_nls_pert
     module procedure exact_nls_pert_1dz
     module procedure exact_nls_pert_2dz
     module procedure exact_nls_pert_3dz
     module procedure exact_nls_pert_1d
     module procedure exact_nls_pert_2d
     module procedure exact_nls_pert_3d
  end interface exact_nls_pert
  interface exact_kdv
     module procedure exact_kdv_1d
     module procedure exact_kdv_1dz
!!$     module procedure exact_kdv_2d
!!$     module procedure exact_kdv_3d
!!$     module procedure exact_kdv_2dz
!!$     module procedure exact_kdv_3dz
  end interface exact_kdv

contains
  !> Routine to return the exact solution for advection diffusion

  !> Routine to return the exact solution for advection diffusion
  function ad_cos_ex(t, x,nu,v,kfreq,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: v
    real(pfdp), intent(in)  :: nu
    real(pfdp), intent(in)  :: kfreq
    real(pfdp), intent(in)  :: Lx
    real(pfdp)  :: u

    real(pfdp) ::  omega
    omega = kfreq*two_pi/Lx
    u=cos(omega*(x-t*v))*exp(-omega*omega*nu*t)
  end function ad_cos_ex

  subroutine exact_ad_cos_1d(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu,v,kfreq(1),Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = ad_cos_ex(t, x,nu,v,kfreq(1),Lx)
    end do

  end subroutine exact_ad_cos_1d
  subroutine exact_ad_cos_1ds(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu,v,kfreq,Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = ad_cos_ex(t, x,nu,v,kfreq,Lx)
    end do

  end subroutine exact_ad_cos_1ds

  subroutine exact_ad_cos_1dz(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu,v,kfreq(1),Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = ad_cos_ex(t, x,nu,v,kfreq(1),Lx)
    end do

  end subroutine exact_ad_cos_1dz

  subroutine exact_ad_cos_2d(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu,v(2),kfreq(2),Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,uy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)

    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       uy=ad_cos_ex(t, y,nu,v(2),kfreq(2),Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = ad_cos_ex(t, x,nu,v(1),kfreq(1),Lx(1))*uy
       end do
    end do

  end subroutine exact_ad_cos_2d

  subroutine exact_ad_cos_2dz(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu,v(2),kfreq(2),Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,uy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       uy=ad_cos_ex(t, y,nu,v(2),kfreq(2),Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = ad_cos_ex(t, x,nu,v(1),kfreq(1),Lx(1))*uy
       end do
    end do

  end subroutine exact_ad_cos_2dz
  subroutine exact_ad_cos_3d(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu,v(3),kfreq(3),Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,uy,uz

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)

    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       uz=ad_cos_ex(t, z,nu,v(3),kfreq(3),Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          uy=ad_cos_ex(t, y,nu,v(2),kfreq(2),Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = ad_cos_ex(t, x,nu,v(1),kfreq(1),Lx(1))*uy*uz
          end do
       end do
    end do

  end subroutine exact_ad_cos_3d

  subroutine exact_ad_cos_3dz(t, uex,nu,v,kfreq,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu,v(3),kfreq(3),Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,uy,uz

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)

    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       uz=ad_cos_ex(t, z,nu,v(3),kfreq(3),Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          uy=ad_cos_ex(t, y,nu,v(2),kfreq(2),Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = ad_cos_ex(t, x,nu,v(1),kfreq(1),Lx(1))*uy*uz
          end do
       end do
    end do

  end subroutine exact_ad_cos_3dz

  function ad_exp_ex(t, x,nu,v,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: v
    real(pfdp), intent(in)  :: nu
    real(pfdp), intent(in)  :: Lx
    real(pfdp)  :: u

    integer    :: nx, i, ii, k,nbox

    real(pfdp) ::  xx,c,t0

    u=0.0_pfdp
    if (nu .gt. 0.0) then
       t0=0.0025_pfdp/nu
       nbox = ceiling(sqrt(4.0_pfdp*nu*(t0+t)*37.0_pfdp))  !  Decide how many periodic images
       do k = -nbox,nbox
          xx = x- 0.5_pfdp*Lx - t*v + REAL(k,pfdp)*Lx
          u = u + sqrt(t0)/sqrt(t0+t)*exp(-xx*xx/(4.0_pfdp*nu*(t0+t)))
       end do
    else
       nbox = ceiling(sqrt(37.0d0))  !  Decide how many periodic images
       do k = -nbox,nbox
          xx = x - 0.5_pfdp*Lx- t*v  + REAL(k,pfdp)*Lx
          u = u + exp(-xx*xx/(4.0_pfdp*0.0025_pfdp))
       end do

    end if

  end function ad_exp_ex

  subroutine exact_ad_exp_1d(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu,v,Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = ad_exp_ex(t, x,nu,v,Lx)
    end do

  end subroutine exact_ad_exp_1d

  subroutine exact_ad_exp_1dz(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu,v,Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = ad_exp_ex(t, x,nu,v,Lx)
    end do

  end subroutine exact_ad_exp_1dz

  subroutine exact_ad_exp_2d(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu,v(2),Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,uy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)

    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       uy=ad_exp_ex(t, y,nu,v(2),Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = ad_exp_ex(t, x,nu,v(1),Lx(1))*uy
       end do
    end do

  end subroutine exact_ad_exp_2d

  subroutine exact_ad_exp_2dz(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu,v(2),Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,uy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       uy=ad_exp_ex(t, y,nu,v(2),Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = ad_exp_ex(t, x,nu,v(1),Lx(1))*uy
       end do
    end do

  end subroutine exact_ad_exp_2dz
  subroutine exact_ad_exp_3d(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu,v(3),Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,uy,uz

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)

    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       uz=ad_exp_ex(t, z,nu,v(3),Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          uy=ad_exp_ex(t, y,nu,v(2),Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = ad_exp_ex(t, x,nu,v(1),Lx(1))*uy*uz
          end do
       end do
    end do

  end subroutine exact_ad_exp_3d

  subroutine exact_ad_exp_3dz(t, uex,nu,v,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu,v(3),Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,uy,uz

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)

    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       uz=ad_exp_ex(t, z,nu,v(3),Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          uy=ad_exp_ex(t, y,nu,v(2),Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = ad_exp_ex(t, x,nu,v(1),Lx(1))*uy*uz
          end do
       end do
    end do

  end subroutine exact_ad_exp_3dz

  !> Routine to return the exact solution for inviscid Burgers based on Platzman
  !>See "A Simple Illustration of a Weak Spectral Cascade", Muraki D,SIAM J Appl Math,2007
  function burg_sin_ex(t, x,nu,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: nu
    real(pfdp), intent(in)  :: Lx
    real(pfdp)  :: u

    real(pfdp) :: rn,ts,xs,a,b,c,phi,dphi,o1,o2
    integer :: n,nterms

    nterms = 100
    u=0.0_pfdp
    xs=x
    ts=t

    if (t .gt. 0.0_pfdp) then
       do n =  nterms,1,-1
          rn = REAL(n,pfdp)
          u=u - 2.0_pfdp*bessel_jn(n,nu*rn*ts)/(rn*ts)*sin(rn*xs)
       end do
    else
       u=-sin(xs)
    end if

  end function burg_sin_ex

  subroutine exact_burg_sin_1d(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = burg_sin_ex(t, x,nu,Lx)
    end do

  end subroutine exact_burg_sin_1d

  subroutine exact_burg_sin_1dz(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = burg_sin_ex(t, x,nu,Lx)
    end do

  end subroutine exact_burg_sin_1dz

  subroutine exact_burg_sin_2d(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,uy,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    L=0.5_pfdp*(Lx(1)+Lx(2))
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = burg_sin_ex(2.0_pfdp*t, x+y,nu,L)
       end do
    end do

  end subroutine exact_burg_sin_2d

  subroutine exact_burg_sin_2dz(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    L=0.5_pfdp*(Lx(1)+Lx(2))
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = burg_sin_ex(2.0_pfdp*t,x+y,nu,L)
       end do
    end do

  end subroutine exact_burg_sin_2dz
  subroutine exact_burg_sin_3d(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    L=(Lx(1)+Lx(2)+Lx(3))/3.0_pfdp
    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = burg_sin_ex(3.0_pfdp*t, x+y+z,nu,L)
          end do
       end do
    end do

  end subroutine exact_burg_sin_3d

  subroutine exact_burg_sin_3dz(t, uex,nu,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: nu
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    L=(Lx(1)+Lx(2)+Lx(3))/3.0_pfdp
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = burg_sin_ex(3.0_pfdp*t,x+y+z,nu,L)
          end do
       end do
    end do

  end subroutine exact_burg_sin_3dz

  !> Routine to return the exact solution for the nonlinear Schoedinger Eq  u_t=i2}u|^2u +i u_xx
  !>See Tuncay Aktosun et al 2007 Inverse Problems 23 217
  !>  Note the domain size should be 2*pi
  function nls_ex(t, x,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: Lx
    complex(pfdp)  :: u

    real(pfdp) :: a,b,taa,c
    complex(pfdp) :: ae,dn

    a=1.0_pfdp/sqrt(2.0_pfdp)
    b=1.0_pfdp
    taa=1.0_pfdp
    ae=a*exp(zi*t)
    dn=cosh(t) + zi*sinh(t)
    c = 4.0_pfdp

    u=exp(zi*c*(x-c*t))*ae*(dn/(cosh(t)-sqrt(2.0_pfdp)/2.0_pfdp*cos(x-2.0_pfdp*c*t))-1.0_pfdp)

  end function nls_ex

  subroutine exact_nls_1dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = nls_ex(t, x,Lx)
    end do

  end subroutine exact_nls_1dz

  subroutine exact_nls_2dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    L=0.5_pfdp*(Lx(1)+Lx(2))
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = nls_ex(2.0_pfdp*t,x+y,L)
       end do
    end do

  end subroutine exact_nls_2dz

  subroutine exact_nls_3dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    L=(Lx(1)+Lx(2)+Lx(3))/3.0_pfdp
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = nls_ex(3.0_pfdp*t,x+y+z,L)
          end do
       end do
    end do

  end subroutine exact_nls_3dz
  function nls_sg_ex(t, x,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: Lx
    real(pfdp)  :: u

    real(pfdp) :: sigma,xx
    complex(pfdp) :: ae,dn
    sigma=0.02_pfdp
    xx=(x-Lx*0.5_pfdp)/(sigma*Lx)
    u=exp(-(xx*xx*xx*xx))

  end function nls_sg_ex
  subroutine exact_nls_sg_1dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = nls_sg_ex(t, x,Lx)
    end do

  end subroutine exact_nls_sg_1dz

  subroutine exact_nls_sg_2dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       sy=nls_sg_ex(t, y,Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = nls_sg_ex(t, x,Lx(1))*sy
       end do
    end do

  end subroutine exact_nls_sg_2dz

  subroutine exact_nls_sg_3dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L
    real(pfdp) :: sz, sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       sz = nls_sg_ex(t, z,Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          sy = nls_sg_ex(t, y,Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = nls_sg_ex(t, x,Lx(1))*sy*sz
          end do
       end do
    end do

  end subroutine exact_nls_sg_3dz

  subroutine exact_nls_sg_1d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = nls_sg_ex(t, x,Lx)
    end do

  end subroutine exact_nls_sg_1d

  subroutine exact_nls_sg_2d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       sy=nls_sg_ex(t, y,Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = nls_sg_ex(t, x,Lx(1))*sy
       end do
    end do

  end subroutine exact_nls_sg_2d

  subroutine exact_nls_sg_3d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L
    real(pfdp) :: sz, sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       sz = nls_sg_ex(t, z,Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          sy = nls_sg_ex(t, y,Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = nls_sg_ex(t, x,Lx(1))*sy*sz
          end do
       end do
    end do

  end subroutine exact_nls_sg_3d
  function nls_pert_ex(t, x,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: Lx
    complex(pfdp)  :: u

    real(pfdp) :: eps
    eps=0.01_pfdp

    !    u=1.0_pfdp+eps*exp(zi*x*0.25_pfdp-2.0_pfdp*two_pi)
    !    u=1.0_pfdp+eps*exp(zi*(x-2.0_pfdp*two_pi)*0.25_pfdp)
    u=1.0_pfdp+eps*exp(zi*(x)*0.25_pfdp)

  end function nls_pert_ex
  subroutine exact_nls_pert_1dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)-0.5_pfdp*Lx
       uex(i) = nls_pert_ex(t, x,Lx)
    end do

  end subroutine exact_nls_pert_1dz

  subroutine exact_nls_pert_2dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       sy=nls_pert_ex(t, y,Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = nls_pert_ex(t, x,Lx(1))*sy
       end do
    end do

  end subroutine exact_nls_pert_2dz

  subroutine exact_nls_pert_3dz(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L
    real(pfdp) :: sz, sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       sz = nls_pert_ex(t, z,Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          sy = nls_pert_ex(t, y,Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = nls_pert_ex(t, x,Lx(1))*sy*sz
          end do
       end do
    end do

  end subroutine exact_nls_pert_3dz
  subroutine exact_nls_pert_1d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = nls_pert_ex(t, x,Lx)
    end do

  end subroutine exact_nls_pert_1d

  subroutine exact_nls_pert_2d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       sy=nls_pert_ex(t, y,Lx(2))
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = nls_pert_ex(t, x,Lx(1))*sy
       end do
    end do

  end subroutine exact_nls_pert_2d

  subroutine exact_nls_pert_3d(t, uex,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L
    real(pfdp) :: sz, sy

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    do k = 1, nz
       z = Lx(3)*real(k-1,pfdp)/REAL(nz,pfdp)
       sz = nls_pert_ex(t, z,Lx(3))
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          sy = nls_pert_ex(t, y,Lx(2))
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = nls_pert_ex(t, x,Lx(1))*sy*sz
          end do
       end do
    end do

  end subroutine exact_nls_pert_3d

  !  Soliton exact solution to kdv  moving at speed one (must scale equation properly)
  function kdv_ex(t, x,beta,Lx) result(u)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(in)  :: x
    real(pfdp), intent(in)  :: beta
    real(pfdp), intent(in)  :: Lx
    real(pfdp)  :: u

    real(pfdp) :: a,s

    a=beta*(x-0.375_pfdp*Lx-t)
    s = 2.0_pfdp/(exp(a)+exp(-a))
    u=s*s

  end function kdv_ex

  subroutine exact_kdv_1dz(t, uex,beta,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in)  :: beta
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = kdv_ex(t, x,beta,Lx)
    end do

  end subroutine exact_kdv_1dz
  subroutine exact_kdv_1d(t, uex,beta,Lx)
    real(pfdp), intent(in)  :: t
    real(pfdp), intent(inout) :: uex(:)
    real(pfdp), intent(in)  :: beta
    real(pfdp), intent(in) :: Lx

    integer    :: nx, i
    real(pfdp) :: x

    nx = SIZE(uex)
    do i = 1, nx
       x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
       uex(i) = kdv_ex(t, x,beta,Lx)
    end do

  end subroutine exact_kdv_1d

  subroutine exact_kdv_2dz(t, uex,beta,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:)
    real(pfdp), intent(in)  :: beta
    real(pfdp), intent(in) :: Lx(2)

    integer    :: nx,ny, i,j
    real(pfdp) :: x, y,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    L=0.5_pfdp*(Lx(1)+Lx(2))
    do j = 1, ny
       y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
       do i = 1, nx
          x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
          uex(i,j) = kdv_ex(2.0_pfdp*t,x,beta,L)
       end do
    end do

  end subroutine exact_kdv_2dz

  subroutine exact_kdv_3dz(t, uex,beta,Lx)
    real(pfdp), intent(in)  :: t
    complex(pfdp), intent(inout) :: uex(:,:,:)
    real(pfdp), intent(in)  :: beta
    real(pfdp), intent(in) :: Lx(3)

    integer    :: nx,ny,nz, i,j,k
    real(pfdp) :: x, y,z,L

    nx = SIZE(uex,1)
    ny = SIZE(uex,2)
    nz = SIZE(uex,3)
    L=(Lx(1)+Lx(2)+Lx(3))/3.0_pfdp
    do k = 1, nz
       z = Lx(3)*REAL(k-1,pfdp)/REAL(nz,pfdp)
       do j = 1, ny
          y = Lx(2)*REAL(j-1,pfdp)/REAL(ny,pfdp)
          do i = 1, nx
             x = Lx(1)*REAL(i-1,pfdp)/REAL(nx,pfdp)
             uex(i,j,k) = kdv_ex(3.0_pfdp*t,x,beta,L)
          end do
       end do
    end do

  end subroutine exact_kdv_3dz

  !  Initial conditions for ML games
  subroutine init_ML_1dz(u,Lx,ic_bar,ic_type)
    complex(pfdp), intent(inout) :: u(:)
    real(pfdp), intent(in) :: Lx
    integer, intent(in) :: ic_type
    real(pfdp), intent(in) :: ic_bar(:)

    integer    :: nx, i,j
    real(pfdp) :: x, xrand(8,2),ixrand(2)

    nx = SIZE(u)
    select case (ic_type)
    case (0)
       !  eight random fourier modes
       call random_number(xrand)
       do i = 1, nx
          x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
          u(i)=0.0_pfdp
          do j = 1,8
             u(i) = u(i)+ xrand(j,1)*sin(real(j,pfdp)*x)+xrand(j,2)*cos(real(j,pfdp)*x)
          end do
       end do
    case (1)
       ! weird exponential thing
       call random_number(ixrand)
       ixrand=real(ceiling(ixrand*7))
       do i = 1, nx
          x = Lx*REAL(i-1,pfdp)/REAL(nx,pfdp)
          u(i)=sin(ixrand(1)*x)*exp(cos(ixrand(2)*x))
       end do
    case DEFAULT
       call pf_stop(__FILE__,__LINE__,'Bad case in SELECT',ic_type)
    end select

  end subroutine init_ML_1dz

end module pf_mod_solutions


program test
  real(kind = 8), parameter :: PI = 3.14
  print *, sin(3.14)
end program test


program forall_test
    use, intrinsic :: iso_fortran_env, only : sp => REAL32
    implicit none
    integer, parameter :: N = 5
    real(kind=sp), dimension(N, N) :: A
    integer :: i, j
    character(len=40) :: fmt_str

    write (fmt_str, "('(', I2, 'F5.2)')") N

    A = 0.0_sp
    forall (i = 1:N, j = 1:N, i == j - 1 .or. i == j + 1)
        A(i, j) = 1.0_sp
    end forall

    do i = 1, N
        print fmt_str, A(i, :)
    end do

end program forall_test


Module m_fndnth
Integer, Parameter :: kdp = selected_real_kind(15)
public :: fndnth
private :: kdp
private :: R_fndnth, I_fndnth, D_fndnth
interface fndnth
  module procedure d_fndnth, r_fndnth, i_fndnth
end interface fndnth
contains

Function D_fndnth (XDONT, NORD) Result (FNDNTH)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! ______________________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It is faster when NORD is very small (2-5),
!  and it requires only a workarray of size NORD and type of XDONT,
!  but worst case behavior can happen fairly probably (initially inverse
!  sorted). In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! __________________________________________________________
      Real (Kind=kdp), Dimension (:), Intent (In) :: XDONT
      Real (Kind=kdp) :: FNDNTH
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real (Kind=kdp), Dimension (NORD) :: XWRKT
      Real (Kind=kdp) :: XWRK, XWRK1
!
!
      Integer :: ICRS, IDCR, ILOW, NDON
!
      XWRKT (1) = XDONT (1)
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XWRKT(IDCR)) Exit
            XWRKT (IDCR+1) = XWRKT (IDCR)
         End Do
         XWRKT (IDCR+1) = XWRK
      End Do
!
      NDON = SIZE (XDONT)
      XWRK1 = XWRKT (NORD)
      ILOW = 2*NORD - NDON
      Do ICRS = NORD + 1, NDON
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            Do IDCR = NORD - 1, MAX (1, ILOW) , - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
            XWRK1 = XWRKT(NORD)
         End If
         ILOW = ILOW + 1
      End Do
      FNDNTH = XWRK1

!
End Function D_fndnth

Function R_fndnth (XDONT, NORD) Result (FNDNTH)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! ______________________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It is faster when NORD is very small (2-5),
!  and it requires only a workarray of size NORD and type of XDONT,
!  but worst case behavior can happen fairly probably (initially inverse
!  sorted). In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Real :: FNDNTH
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real, Dimension (NORD) :: XWRKT
      Real :: XWRK, XWRK1
!
!
      Integer :: ICRS, IDCR, ILOW, NDON
!
      XWRKT (1) = XDONT (1)
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XWRKT(IDCR)) Exit
            XWRKT (IDCR+1) = XWRKT (IDCR)
         End Do
         XWRKT (IDCR+1) = XWRK
      End Do
!
      NDON = SIZE (XDONT)
      XWRK1 = XWRKT (NORD)
      ILOW = 2*NORD - NDON
      Do ICRS = NORD + 1, NDON
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            Do IDCR = NORD - 1, MAX (1, ILOW) , - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
            XWRK1 = XWRKT(NORD)
         End If
         ILOW = ILOW + 1
      End Do
      FNDNTH = XWRK1

!
End Function R_fndnth
Function I_fndnth (XDONT, NORD) Result (FNDNTH)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! ______________________________________________________________________
!  This subroutine uses insertion sort, limiting insertion
!  to the first NORD values. It is faster when NORD is very small (2-5),
!  and it requires only a workarray of size NORD and type of XDONT,
!  but worst case behavior can happen fairly probably (initially inverse
!  sorted). In many cases, the refined quicksort method is faster.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In) :: XDONT
      Integer :: fndnth
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Integer, Dimension (NORD) :: XWRKT
      Integer :: XWRK, XWRK1
!
!
      Integer :: ICRS, IDCR, ILOW, NDON
!
      XWRKT (1) = XDONT (1)
      Do ICRS = 2, NORD
         XWRK = XDONT (ICRS)
         Do IDCR = ICRS - 1, 1, - 1
            If (XWRK >= XWRKT(IDCR)) Exit
            XWRKT (IDCR+1) = XWRKT (IDCR)
         End Do
         XWRKT (IDCR+1) = XWRK
      End Do
!
      NDON = SIZE (XDONT)
      XWRK1 = XWRKT (NORD)
      ILOW = 2*NORD - NDON
      Do ICRS = NORD + 1, NDON
         If (XDONT(ICRS) < XWRK1) Then
            XWRK = XDONT (ICRS)
            Do IDCR = NORD - 1, MAX (1, ILOW) , - 1
               If (XWRK >= XWRKT(IDCR)) Exit
               XWRKT (IDCR+1) = XWRKT (IDCR)
            End Do
            XWRKT (IDCR+1) = XWRK
            XWRK1 = XWRKT(NORD)
         End If
         ILOW = ILOW + 1
      End Do
      FNDNTH = XWRK1

!
End Function I_fndnth
end module m_fndnth


! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     https://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module vs_algorithm

  use, intrinsic :: iso_c_binding, only: &
       c_double, c_int, c_int32_t, c_int64_t
  use types, only: dp
  implicit none
  public vs_algorithm32, vs_algorithm53, vs_algorithm64

contains

  subroutine vs_algorithm32( &
       num_nodes, dimension_, nodes, num_vals, s_vals, evaluated) &
       bind(c, name='BAKEOFF&
       &OPT&
       &_vs_algorithm32')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: s_vals(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    real(c_double) :: one_less(num_vals), s_pow(num_vals)
    integer(c_int) :: i, j
    integer(c_int32_t) :: binom_val

    one_less = 1.0_dp - s_vals
    s_pow = 1.0_dp
    binom_val = 1

    forall (i = 1:num_vals)
       evaluated(:, i) = one_less(i) * nodes(:, 1)
    end forall

    do i = 2, num_nodes - 1
       s_pow = s_pow * s_vals
       binom_val = (binom_val * (num_nodes - i + 1)) / (i - 1)
       forall (j = 1:num_vals)
          evaluated(:, j) = ( &
               evaluated(:, j) + &
               binom_val * s_pow(j) * nodes(:, i)) * one_less(j)
       end forall
    end do

    forall (i = 1:num_vals)
       evaluated(:, i) = ( &
            evaluated(:, i) + &
            s_pow(i) * s_vals(i) * nodes(:, num_nodes))
    end forall

  end subroutine vs_algorithm32

  subroutine vs_algorithm53( &
       num_nodes, dimension_, nodes, num_vals, s_vals, evaluated) &
       bind(c, name='BAKEOFF&
       &OPT&
       &_vs_algorithm53')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: s_vals(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    real(c_double) :: one_less(num_vals), s_pow(num_vals)
    integer(c_int) :: i, j
    real(c_double) :: binom_val

    one_less = 1.0_dp - s_vals
    s_pow = 1.0_dp
    binom_val = 1

    forall (i = 1:num_vals)
       evaluated(:, i) = one_less(i) * nodes(:, 1)
    end forall

    do i = 2, num_nodes - 1
       s_pow = s_pow * s_vals
       binom_val = (binom_val * (num_nodes - i + 1)) / (i - 1)
       forall (j = 1:num_vals)
          evaluated(:, j) = ( &
               evaluated(:, j) + &
               binom_val * s_pow(j) * nodes(:, i)) * one_less(j)
       end forall
    end do

    forall (i = 1:num_vals)
       evaluated(:, i) = ( &
            evaluated(:, i) + &
            s_pow(i) * s_vals(i) * nodes(:, num_nodes))
    end forall

  end subroutine vs_algorithm53

  subroutine vs_algorithm64( &
       num_nodes, dimension_, nodes, num_vals, s_vals, evaluated) &
       bind(c, name='BAKEOFF&
       &OPT&
       &_vs_algorithm64')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: s_vals(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    real(c_double) :: one_less(num_vals), s_pow(num_vals)
    integer(c_int) :: i, j
    integer(c_int64_t) :: binom_val

    one_less = 1.0_dp - s_vals
    s_pow = 1.0_dp
    binom_val = 1

    forall (i = 1:num_vals)
       evaluated(:, i) = one_less(i) * nodes(:, 1)
    end forall

    do i = 2, num_nodes - 1
       s_pow = s_pow * s_vals
       binom_val = (binom_val * (num_nodes - i + 1)) / (i - 1)
       forall (j = 1:num_vals)
          evaluated(:, j) = ( &
               evaluated(:, j) + &
               binom_val * s_pow(j) * nodes(:, i)) * one_less(j)
       end forall
    end do

    forall (i = 1:num_vals)
       evaluated(:, i) = ( &
            evaluated(:, i) + &
            s_pow(i) * s_vals(i) * nodes(:, num_nodes))
    end forall

  end subroutine vs_algorithm64

end module vs_algorithm


*> \brief \b SCHKPS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
*                          THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
*                          RWORK, NOUT )
*
*       .. Scalar Arguments ..
*       REAL               THRESH
*       INTEGER            NMAX, NN, NNB, NOUT, NRANK
*       LOGICAL            TSTERR
*       ..
*       .. Array Arguments ..
*       REAL               A( * ), AFAC( * ), PERM( * ), RWORK( * ),
*      $                   WORK( * )
*       INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
*       LOGICAL            DOTYPE( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SCHKPS tests SPSTRF.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The matrix types to be used for testing.  Matrices of type j
*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>          The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>          The values of the matrix dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*>          NNB is INTEGER
*>          The number of values of NB contained in the vector NBVAL.
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*>          NBVAL is INTEGER array, dimension (NBVAL)
*>          The values of the block size NB.
*> \endverbatim
*>
*> \param[in] NRANK
*> \verbatim
*>          NRANK is INTEGER
*>          The number of values of RANK contained in the vector RANKVAL.
*> \endverbatim
*>
*> \param[in] RANKVAL
*> \verbatim
*>          RANKVAL is INTEGER array, dimension (NBVAL)
*>          The values of the block size NB.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*>          TSTERR is LOGICAL
*>          Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NMAX
*> \verbatim
*>          NMAX is INTEGER
*>          The maximum value permitted for N, used in dimensioning the
*>          work arrays.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AFAC
*> \verbatim
*>          AFAC is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] PERM
*> \verbatim
*>          PERM is REAL array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] PIV
*> \verbatim
*>          PIV is INTEGER array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (NMAX*3)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (NMAX)
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
     $                   THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
     $                   RWORK, NOUT )
*
*  -- LAPACK test 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 ..
      REAL               THRESH
      INTEGER            NMAX, NN, NNB, NOUT, NRANK
      LOGICAL            TSTERR
*     ..
*     .. Array Arguments ..
      REAL               A( * ), AFAC( * ), PERM( * ), RWORK( * ),
     $                   WORK( * )
      INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
      LOGICAL            DOTYPE( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
      INTEGER            NTYPES
      PARAMETER          ( NTYPES = 9 )
*     ..
*     .. Local Scalars ..
      REAL               ANORM, CNDNUM, RESULT, TOL
      INTEGER            COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
     $                   IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
     $                   NIMAT, NRUN, RANK, RANKDIFF
      CHARACTER          DIST, TYPE, UPLO
      CHARACTER*3        PATH
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      CHARACTER          UPLOS( 2 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAERH, ALAHD, ALASUM, SERRPS, SLACPY, SLATB5,
     $                   SLATMT, SPST01, SPSTRF, XLAENV
*     ..
*     .. Scalars in Common ..
      INTEGER            INFOT, NUNIT
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, REAL, CEILING
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
      DATA               UPLOS / 'U', 'L' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 1 ) = 'Single Precision'
      PATH( 2: 3 ) = 'PS'
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 100 I = 1, 4
         ISEED( I ) = ISEEDY( I )
  100 CONTINUE
*
*     Test the error exits
*
      IF( TSTERR )
     $   CALL SERRPS( PATH, NOUT )
      INFOT = 0
      CALL XLAENV( 2, 2 )
*
*     Do for each value of N in NVAL
*
      DO 150 IN = 1, NN
         N = NVAL( IN )
         LDA = MAX( N, 1 )
         NIMAT = NTYPES
         IF( N.LE.0 )
     $      NIMAT = 1
*
         IZERO = 0
         DO 140 IMAT = 1, NIMAT
*
*           Do the tests only if DOTYPE( IMAT ) is true.
*
            IF( .NOT.DOTYPE( IMAT ) )
     $         GO TO 140
*
*              Do for each value of RANK in RANKVAL
*
            DO 130 IRANK = 1, NRANK
*
*              Only repeat test 3 to 5 for different ranks
*              Other tests use full rank
*
               IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
     $            GO TO 130
*
               RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) )
     $              / 100.E+0 )
*
*
*           Do first for UPLO = 'U', then for UPLO = 'L'
*
               DO 120 IUPLO = 1, 2
                  UPLO = UPLOS( IUPLO )
*
*              Set up parameters with SLATB5 and generate a test matrix
*              with SLATMT.
*
                  CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
     $                         MODE, CNDNUM, DIST )
*
                  SRNAMT = 'SLATMT'
                  CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
     $                         CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
     $                         LDA, WORK, INFO )
*
*              Check error code from SLATMT.
*
                  IF( INFO.NE.0 ) THEN
                    CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N,
     $                           N, -1, -1, -1, IMAT, NFAIL, NERRS,
     $                           NOUT )
                     GO TO 120
                  END IF
*
*              Do for each value of NB in NBVAL
*
                  DO 110 INB = 1, NNB
                     NB = NBVAL( INB )
                     CALL XLAENV( 1, NB )
*
*                 Compute the pivoted L*L' or U'*U factorization
*                 of the matrix.
*
                     CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
                     SRNAMT = 'SPSTRF'
*
*                 Use default tolerance
*
                     TOL = -ONE
                     CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
     $                            TOL, WORK, INFO )
*
*                 Check error code from SPSTRF.
*
                     IF( (INFO.LT.IZERO)
     $                    .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
     $                    .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
                        CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO,
     $                               UPLO, N, N, -1, -1, NB, IMAT,
     $                               NFAIL, NERRS, NOUT )
                        GO TO 110
                     END IF
*
*                 Skip the test if INFO is not 0.
*
                     IF( INFO.NE.0 )
     $                  GO TO 110
*
*                 Reconstruct matrix from factors and compute residual.
*
*                 PERM holds permuted L*L^T or U^T*U
*
                     CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
     $                            PIV, RWORK, RESULT, COMPRANK )
*
*                 Print information about the tests that did not pass
*                 the threshold or where computed rank was not RANK.
*
                     IF( N.EQ.0 )
     $                  COMPRANK = 0
                     RANKDIFF = RANK - COMPRANK
                     IF( RESULT.GE.THRESH ) THEN
                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                     CALL ALAHD( NOUT, PATH )
                        WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
     $                     RANKDIFF, NB, IMAT, RESULT
                        NFAIL = NFAIL + 1
                     END IF
                     NRUN = NRUN + 1
  110             CONTINUE
*
  120          CONTINUE
  130       CONTINUE
  140    CONTINUE
  150 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
     $      ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
     $      G12.5 )
      RETURN
*
*     End of SCHKPS
*
      END