module mod_monolis_stdlib
  use mod_monolis_prm
  implicit none

contains

  function monolis_normalize_cross_product_3d(a, b)
    implicit none
    real(kdouble) :: monolis_normalize_cross_product_3d(3), a(3), b(3), norm(3), l2

    norm(1) = a(2)*b(3) - a(3)*b(2)
    norm(2) = a(3)*b(1) - a(1)*b(3)
    norm(3) = a(1)*b(2) - a(2)*b(1)
    l2 = dsqrt(norm(1)*norm(1) + norm(2)*norm(2) + norm(3)*norm(3))
    if(l2 == 0.0d0)then
      monolis_normalize_cross_product_3d = 0.0d0
      return
    endif
    monolis_normalize_cross_product_3d = norm/l2
  end function monolis_normalize_cross_product_3d

  function monolis_normalize_vector(n, a)
    implicit none
    integer(kint) :: i, n
    real(kdouble) :: monolis_normalize_vector(n), a(n), l2

    l2 = 0.0d0
    do i = 1, n
      l2 = l2 + a(i)*a(i)
    enddo
    l2 = dsqrt(l2)
    if(l2 == 0.0d0)then
      monolis_normalize_vector = 0.0d0
      return
    endif
    monolis_normalize_vector = a/l2
  end function monolis_normalize_vector

  function monolis_get_l2_norm(n, a)
    implicit none
    integer(kint) :: i, n
    real(kdouble) :: monolis_get_l2_norm, a(n), l2

    l2 = 0.0d0
    do i = 1, n
      l2 = l2 + a(i)*a(i)
    enddo
    monolis_get_l2_norm = dsqrt(l2)
  end function monolis_get_l2_norm

  subroutine monolis_global_to_local_elem(nnode, nid, nelem, e, nenode)
    implicit none
    integer(kint) :: i, in, j, id, nenode
    integer(kint) :: nnode, nid(:)
    integer(kint) :: nelem, e(:,:)
    integer(kint), allocatable :: perm(:), temp(:)

    allocate(temp(nnode), source = 0)
    allocate(perm(nnode), source = 0)
    do i = 1, nnode
      temp(i) = nid(i)
      perm(i) = i
    enddo
    call monolis_qsort_int_with_perm(temp, 1, nnode, perm)

    do i = 1, nelem
      do j = 1, nenode
        in = e(j,i)
        call monolis_bsearch_int(temp, 1, nnode, in, id)
        if(id == -1)then
          e(j,i) = -1
        else
          e(j,i) = perm(id)
        endif
      enddo
    enddo
  end subroutine monolis_global_to_local_elem

  subroutine monolis_global_to_local_conditoin(nnode, nid, nb, b)
    implicit none
    integer(kint) :: i, in, id, nb
    integer(kint) :: nnode, nid(:)
    integer(kint) :: b(:,:)
    integer(kint), allocatable :: temp(:), perm(:)

    allocate(temp(nnode), source = 0)
    allocate(perm(nnode), source = 0)
    do i = 1, nnode
      temp(i) = nid(i)
      perm(i) = i
    enddo
    call monolis_qsort_int_with_perm(temp, 1, nnode, perm)

    do i = 1, nb
      in = b(1,i)
      call monolis_bsearch_int(temp, 1, nnode, in, id)
      if(id == -1)then
        b(1,i) = -1
      else
        b(1,i) = perm(id)
      endif
    enddo
  end subroutine monolis_global_to_local_conditoin

  subroutine monolis_get_inverse_matrix(n, a, inv)
    implicit none
    integer(kint) :: n, i, j, k
    real(kdouble) :: a(n,n), inv(n,n), tmp

    inv = 0.0d0
    do i = 1, n
      inv(i,i) = 1.0d0
    enddo

    do i = 1, n
      tmp = 1.0d0/a(i,i)
      do j = 1, n
          a(j,i) =   a(j,i) * tmp
        inv(j,i) = inv(j,i) * tmp
      enddo
      do j = 1, n
        if(i /= j) then
          tmp = a(i,j)
          do k = 1, n
              a(k,j) =   a(k,j) -   a(k,i) * tmp
            inv(k,j) = inv(k,j) - inv(k,i) * tmp
          enddo
        endif
      enddo
    enddo
  end subroutine monolis_get_inverse_matrix

  recursive subroutine monolis_qsort_int(array, iS, iE)
    implicit none
    integer(kint), intent(inout) :: array(:)
    integer(kint), intent(in) :: iS, iE
    integer(kint) :: pivot, center, left, right, tmp

    if (iS >= iE) return

    center = (iS + iE) / 2
    pivot = array(center)
    left = iS
    right = iE

    do
      do while (array(left) < pivot)
        left = left + 1
      enddo
      do while (pivot < array(right))
        right = right - 1
      enddo

      if (left >= right) exit

      tmp = array(left)
      array(left) = array(right)
      array(right) = tmp

      left = left + 1
      right = right - 1
    enddo

    if(iS < left-1)  call monolis_qsort_int(array, iS, left-1)
    if(right+1 < iE) call monolis_qsort_int(array, right+1, iE)
  end subroutine monolis_qsort_int

  recursive subroutine monolis_qsort_int_with_perm(array, iS, iE, perm)
    implicit none
    integer(kint), intent(inout) :: array(:), perm(:)
    integer(kint), intent(in) :: iS, iE
    integer(kint) :: pivot, center, left, right, tmp

    if (iS >= iE) return

    center = (iS + iE) / 2
    pivot = array(center)
    left = iS
    right = iE

    do
      do while (array(left) < pivot)
        left = left + 1
      enddo
      do while (pivot < array(right))
        right = right - 1
      enddo

      if (left >= right) exit

      tmp = array(left)
      array(left) = array(right)
      array(right) = tmp

      tmp = perm(left)
      perm(left) = perm(right)
      perm(right) = tmp

      left = left + 1
      right = right - 1
    enddo

    if(iS < left-1)  call monolis_qsort_int_with_perm(array, iS, left-1, perm)
    if(right+1 < iE) call monolis_qsort_int_with_perm(array, right+1, iE, perm)
  end subroutine monolis_qsort_int_with_perm

  subroutine monolis_bsearch_int(array, iS, iE, val, idx)
    implicit none
    integer(kint), intent(in) :: array(:)
    integer(kint), intent(in) :: iS, iE
    integer(kint), intent(in) :: val
    integer(kint), intent(out) :: idx
    integer(kint) :: center, left, right, pivot

    left = iS
    right = iE

    do
      if (left > right) then
        idx = -1
        exit
      endif
      center = (left + right) / 2
      pivot = array(center)
      if (val < pivot) then
        right = center - 1
        cycle
      elseif (pivot < val) then
        left = center + 1
        cycle
      else
        idx = center
        exit
      endif
    enddo
  end subroutine monolis_bsearch_int

  subroutine monolis_bsearch_int_with_position(array, iS, iE, val, idx, pos)
    implicit none
    integer(kint), intent(in) :: array(:)
    integer(kint), intent(in) :: iS, iE
    integer(kint), intent(in) :: val
    integer(kint), intent(out) :: idx, pos
    integer(kint) :: center, left, right, pivot

    pos = -1
    left = iS
    right = iE

    do
      if (left > right) then
        idx = -1
        pos = right
        exit
      endif
      center = (left + right) / 2
      pivot = array(center)
      if (val < pivot) then
        right = center - 1
        cycle
      elseif (pivot < val) then
        left = center + 1
        cycle
      else
        idx = center
        pos = -1
        exit
      endif
    enddo
  end subroutine monolis_bsearch_int_with_position

  subroutine monolis_uniq_int(array, len, newlen)
    implicit none
    integer(kint), intent(inout) :: array(:)
    integer(kint), intent(in) :: len
    integer(kint), intent(out) :: newlen
    integer(kint) :: i, ndup

    ndup = 0
    do i = 2, len
      if(array(i) == array(i - 1 - ndup))then
        ndup = ndup + 1
      elseif(ndup > 0)then
        array(i - ndup) = array(i)
      endif
    end do
    newlen = len - ndup
  end subroutine monolis_uniq_int

  subroutine monolis_reallocate_integer(array, nold, n, add)
    implicit none
    integer(kint), allocatable :: array(:), temp(:)
    integer(kint) :: i, n, nold, add(n)

    if(nold == 0)then
      allocate(array(n))
    else
      allocate(temp(nold))
      temp = array
      deallocate(array)
      allocate(array(nold + n))

      do i = 1, nold
        array(i) = temp(i)
      enddo
    endif

    do i = nold + 1, nold + n
      array(i) = add(i-nold)
    enddo
  end subroutine monolis_reallocate_integer

  subroutine monolis_pointer_reallocate_integer(array, nold, n, add)
    implicit none
    integer(kint), pointer :: array(:), temp(:)
    integer(kint) :: i, n, nold, add(n)

    if(nold == 0)then
      allocate(array(n))
    else
      allocate(temp(nold))
      temp = array
      deallocate(array)
      allocate(array(nold + n))

      do i = 1, nold
        array(i) = temp(i)
      enddo
    endif

    do i = nold + 1, nold + n
      array(i) = add(i-nold)
    enddo
  end subroutine monolis_pointer_reallocate_integer

end module mod_monolis_stdlib


! ============================================================================
! Name        : main.f90
! Author      : Giovanni Dalmasso
! Date        : Mar 12, 2013
! Version     : 1.1
! Copyright   : Department of Computational Hydrosystems CHS - UZF Leipzig
! Description : main test mo_ode_solver
! ============================================================================

program main_test_mo_ode_solver

    use mo_kind,        only    : i4, sp, dp
    use mo_ansi_colors, only: color, c_red, c_green
    use mo_eq_lv,       only    : LV_eqn_sp, LV_eqn_dp, LV_eqn_para_sp, LV_eqn_para_dp,&
                                  deriv2_testRB_sp, jacobn2_testRB_sp,&
                                  deriv2_testRB_dp, jacobn2_testRB_dp,&
                                  deriv2_testRB_para_sp, jacobn2_testRB_para_sp,&
                                  deriv2_testRB_para_dp, jacobn2_testRB_para_dp
    use mo_ode_solver,  only    : EULER, RK4, RK4as, RBstiff

    implicit none

    integer(i4)                             :: nEq      ! number of equation
    real(sp)                                :: x1       ! initial time point
    real(sp)                                :: x2       ! final time point
    real(sp)                                :: h        ! time step
    real(sp)                                :: hmin     ! minimum allowed stepsize
    real(sp)                                :: eps      ! accurancy
    real(sp)                                :: test     ! test variable
    real(sp), dimension(:),     allocatable :: yi       ! initial conditions
    real(sp), dimension(:),     allocatable :: xout     ! output time
    real(sp), dimension(:,:),   allocatable :: yout     ! output solutions
    real(sp), dimension(3)                  :: para     ! parameter for derivs

    real(dp)                                :: dx1       ! initial time point
    real(dp)                                :: dx2       ! final time point
    real(dp)                                :: dh        ! time step
    real(dp)                                :: dhmin     ! minimum allowed stepsize
    real(dp)                                :: deps      ! accurancy
    real(dp)                                :: dtest     ! test variable
    real(dp), dimension(:),     allocatable :: dyi       ! initial conditions
    real(dp), dimension(:),     allocatable :: dxout     ! output time
    real(dp), dimension(:,:),   allocatable :: dyout     ! output solutions
    real(dp), dimension(3)                  :: dpara     ! parameter for derivs

    logical                                 :: isgood

    isgood = .true.       ! test variable

    ! sp
    test   = 1.0e4_sp     ! test variable

    nEq    = 2_i4         ! number of equations
    x1     = 0._sp        ! intial time
    x2     = 10._sp       ! final time
    h      = 0.1_sp       ! incremental time step
    hmin   = h*1.0e-11_sp ! minimum allowed stepsize
    eps    = 1e-8_sp      ! accuracy

    para   = (/0.5_sp, 2.0_sp, -1.0_sp/)

    allocate( yi(nEq) )
    yi = (/ 1._sp, 1._sp /)         ! initial conditions

    ! Euler method
    call Euler( yi, x1, x2, h, LV_eqn_sp, xout, yout )
    if ( nint(xout(2)*test) .ne. 1000_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 10000_i4, 13000_i4 /)) ) isgood = .false.    ! test
    if (.not. isgood) write(*,*) "euler sp"

    ! 4th order RUNGE-KUTTA method
    call RK4( yi, x1, x2, h, LV_eqn_sp, xout, yout )
    if ( nint(xout(2)*test) .ne. 1000_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 9850_i4, 12835_i4 /)) ) isgood = .false.     ! test
    if (.not. isgood) write(*,*) "rk sp"

    ! 4th order RUNGE-KUTTA Adaptive Step-size
    call RK4as( yi, x1, x2, h, LV_eqn_sp, xout, yout, hmin=hmin, eps=eps )

#if defined (__pgiFortran__) || defined (__INTEL__)
    ! PGI compiler other rounding errors in single precision, Intel in release mode
    if ( nint(xout(2)*test*1.0e-1_sp) .ne. 58_i4 .or. &
         any(nint(yout(2,:)*test*1.0e-1_sp) .ne. (/ 995_i4, 1169_i4 /)) ) isgood = .false.
#else
    if ( nint(xout(2)*test) .ne. 580_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 9950_i4, 11687_i4 /)) ) isgood = .false.
#endif
    ! test
    if (.not. isgood) write(*,*) "rk-as sp"

    ! Rosenbrock Method
    call RBstiff( (/1.0_sp,1.0_sp,0.0_sp/), 0.0_sp, 50.0_sp, 2.9e-4_sp, deriv2_testRB_sp,&
                    jacobn2_testRB_sp, xout, yout, hmin=hmin, eps=1e-4_sp )
    if (    nint(xout(2)*test) .ne. 3_i4 .or.&
            any(nint(yout(2,:)*test) .ne. (/ 10000_i4, 10000_i4, 0_i4 /)) )&
       isgood = .false.    ! test
    if (.not. isgood) write(*,*) "rb-stiff sp"

    !with parameters

    ! Euler method with parameter
    call Euler( yi, x1, x2, h, LV_eqn_para_sp, para, xout, yout )
    if ( nint(xout(2)*test) .ne. 1000_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 10000_i4, 13000_i4 /)) ) isgood = .false.    ! test
    if (.not. isgood) write(*,*) "euler sp para"

    ! 4th order RUNGE-KUTTA method with parameter
    call RK4( yi, x1, x2, h, LV_eqn_para_sp, para, xout, yout )
#if defined (__pgiFortran__) || defined (__INTEL__)
    if ( nint(xout(2)*test*1e-1) .ne. 100_i4 .or. any(nint(yout(2,:)*test*1e-1) .ne. (/ 985_i4, 1284_i4 /)) ) isgood = .false.     ! test
#else
    if ( nint(xout(2)*test) .ne. 1000_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 9850_i4, 12835_i4 /)) ) isgood = .false.     ! test
#endif
    if (.not. isgood) write(*,*) "rk sp para"

    ! 4th order RUNGE-KUTTA Adaptive Step-size with parameter
    call RK4as( yi, x1, x2, h, LV_eqn_para_sp, para, xout, yout, hmin=hmin, eps=eps )
#if defined (__pgiFortran__) || defined (__INTEL__)
    if ( nint(xout(2)*test*1e-1) .ne. 58_i4 .or. any(nint(yout(2,:)*test*1e-1) .ne. (/ 995_i4, 1169_i4 /)) ) isgood = .false.     ! test
#else
    if ( nint(xout(2)*test) .ne. 580_i4 .or. any(nint(yout(2,:)*test) .ne. (/ 9950_i4, 11687_i4 /)) ) isgood = .false.     ! test
#endif
    if (.not. isgood) write(*,*) "rk-as sp para"

    ! Rosenbrock Method with parameter
    call RBstiff( (/1.0_sp,1.0_sp,0.0_sp/), 0.0_sp, 50.0_sp, 2.9e-4_sp, deriv2_testRB_para_sp,&
                    jacobn2_testRB_para_sp, (/1000.0_sp/), xout, yout, hmin=hmin, eps=1e-4_sp )
#if defined (__pgiFortran__) || defined (__INTEL__)
    if (    nint(xout(2)*test*1e-1) .ne. 0_i4 .or.&
            any(nint(yout(2,:)*test*1e-1) .ne. (/ 1000_i4, 1000_i4, 0_i4 /)) )&
       isgood = .false.    ! test
#else
    if (    nint(xout(2)*test) .ne. 3_i4 .or.&
            any(nint(yout(2,:)*test) .ne. (/ 10000_i4, 10000_i4, 0_i4 /)) )&
       isgood = .false.    ! test
#endif
    if (.not. isgood) write(*,*) "rb-stiff sp"

!dp
    dtest   = 1e8_dp     ! test variable

    nEq    = 2_i4       ! number of equations
    dx1     = 0._dp      ! intial time
    dx2     = 10._dp     ! final time
    dh      = 0.1_dp     ! incremental time step
    dhmin   = h*1e-11_dp ! minimum allowed stepsize
    deps    = 1e-8_dp    ! accuracy

    dpara   = (/0.5_dp, 2.0_dp, -1.0_dp/)

    allocate( dyi(nEq) )
    dyi = (/ 1._dp, 1._dp /)         ! initial conditions

    ! Euler method
    call Euler( dyi, dx1, dx2, dh, LV_eqn_dp, dxout, dyout )
    if ( nint(dxout(2)*dtest) .ne. 10000000_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 100000000_i4, 130000000_i4 /)) ) isgood = .false.  ! test
    if (.not. isgood) write(*,*) "euler dp"

    ! 4th order RUNGE-KUTTA method
    call RK4( dyi, dx1, dx2, dh, LV_eqn_dp, dxout, dyout )
    if ( nint(dxout(2)*dtest) .ne. 10000000_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 98503750_i4, 128353750_i4 /)) ) isgood = .false.   ! test
    if (.not. isgood) write(*,*) "rk dp"

    ! 4th order RUNGE-KUTTA Adaptive Step-size
    call RK4as( dyi, dx1, dx2, dh, LV_eqn_dp, dxout, dyout, hmin=dhmin, eps=deps )
    if ( nint(dxout(2)*dtest) .ne. 6008771_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 99458909_i4, 117452697_i4 /)) ) isgood = .false.    ! test
    if (.not. isgood) write(*,*) "rk-as dp"

    ! Rosenbrock Method
    call RBstiff( (/1.0_dp,1.0_dp,0.0_dp/), 0.0_dp, 50.0_dp, 2.9e-4_dp, deriv2_testRB_dp,&
                    jacobn2_testRB_dp, dxout, dyout, hmin=dhmin, eps=1e-4_dp )
    if (    nint(dxout(2)*dtest) .ne. 29000_i4 .or.&
            any(nint(dyout(2,:)*dtest) .ne. (/ 99999663_i4, 100000100_i4, -237_i4 /)) )&
       isgood = .false.    ! test
    if (.not. isgood) write(*,*) "rb-stiff dp"

    !with parameters

    ! Euler method with parameters
    call Euler( dyi, dx1, dx2, dh, LV_eqn_para_dp, dpara, dxout, dyout )
    if ( nint(dxout(2)*dtest) .ne. 10000000_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 100000000_i4, 130000000_i4 /)) ) isgood = .false.  ! test
    if (.not. isgood) write(*,*) "euler dp para"

!    write(*,*) dxout(2), dyout(2,:)
!    write(*,*) nint(dxout(2)*dtest), nint(dyout(2,:)*dtest)

    ! 4th order RUNGE-KUTTA method with parameters
    call RK4( dyi, dx1, dx2, dh, LV_eqn_para_dp, dpara, dxout, dyout )
    if ( nint(dxout(2)*dtest) .ne. 10000000_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 98503750_i4, 128353750_i4 /)) ) isgood = .false.   ! test
    if (.not. isgood) write(*,*) "rk dp para"

!    write(*,*) dxout(2), dyout(2,:)
!    write(*,*) nint(dxout(2)*dtest), nint(dyout(2,:)*dtest)

    ! 4th order RUNGE-KUTTA Adaptive Step-size with parameters
    call RK4as( dyi, dx1, dx2, dh, LV_eqn_para_dp, dpara, dxout, dyout, hmin=dhmin, eps=deps )
    if ( nint(dxout(2)*dtest) .ne. 6008771_i4 .or. &
         any(nint(dyout(2,:)*dtest) .ne. (/ 99458909_i4, 117452697_i4 /)) ) isgood = .false.    ! test
    if (.not. isgood) write(*,*) "rk-as dp para"

!    write(*,*) dxout(2), dyout(2,:)
!    write(*,*) nint(dxout(2)*dtest), nint(dyout(2,:)*dtest)

    ! Rosenbrock Method with parameter
    call RBstiff( (/1.0_dp,1.0_dp,0.0_dp/), 0.0_dp, 50.0_dp, 2.9e-4_dp, deriv2_testRB_para_dp,&
                    jacobn2_testRB_para_dp, (/1000.0_dp/), dxout, dyout, hmin=dhmin, eps=1e-4_dp )
    if (    nint(dxout(2)*dtest) .ne. 29000_i4 .or.&
            any(nint(dyout(2,:)*dtest) .ne. (/ 99999663_i4, 100000100_i4, -237_i4 /)) )&
       isgood = .false.    ! test
    if (.not. isgood) write(*,*) "rb-stiff dp para"

!    write(*,*) dxout(2), dyout(2,:)
!    write(*,*) nint(dxout(2)*dtest), nint(dyout(2,:)*dtest)

! Is the program running properly?
    write(*,*) ''
    write(*,*) '------------------------------------------'
    if (isgood) then
        write(*,*) 'mo_ode_solver ', color('o.k.', c_green)
    else
        write(*,*) 'mo_ode_solver ', color('failed!', c_red)
    endif
    write(*,*) '-------------------END---------------------'

end program main_test_mo_ode_solver


program power
implicit none
integer, parameter :: n = 10**8, dp = kind(1.0d0)
real(kind=dp) :: x(n),t(3)
call random_number(x)
call cpu_time(t(1))
write (*,"(a20,f20.10)") "sum(x**2.0_dp) =",sum(x**2.0_dp)
call cpu_time(t(2))
write (*,"(a20,f20.10)") "sum(x**2) =",sum(x**2)
call cpu_time(t(3))
write (*,"(/,a10,*(1x,a10))") "method","x**2.0_dp","x**2"
write (*,"(a10,*(1x,f10.4))") "time",t(2:3) - t(1:2)
end program power
! gfortran -O0 output
!
!     sum(x**2.0_dp) = 33334073.2750587128
!          sum(x**2) = 33334073.2750587128
!
!     method  x**2.0_dp       x**2
!       time     1.3281     0.1250
!
! for gfortran -O3 the times are the same
! for x**2.0_dp and x**2


module jacobi

  implicit none

contains

subroutine jacobistep(psinew, psi, m, n)

  integer :: m, n
  double precision, dimension(0:m+1, 0:n+1) :: psinew, psi

!$omp parallel workshare
  psinew(1:m, 1:n) = 0.25d0*(psi(2:m+1, 1:n) + psi(0:m-1, 1:n) + &
                             psi(1:m, 2:n+1) + psi(1:m, 0:n-1)     )
!$omp end parallel workshare

end subroutine jacobistep

subroutine jacobistepvort(zetnew, psinew, zet, psi, m, n, re)

  integer :: m, n
  double precision :: re
  double precision, dimension(0:m+1, 0:n+1) :: zetnew, zet, psinew, psi

!$omp parallel workshare
  psinew(1:m, 1:n) = 0.25d0*(psi(2:m+1, 1:n) + psi(0:m-1, 1:n) + &
                             psi(1:m, 2:n+1) + psi(1:m, 0:n-1) - &
                             zet(1:m,   1:n))

  zetnew(1:m, 1:n) = 0.25d0*(zet(2:m+1, 1:n) + zet(0:m-1, 1:n) +     &
                             zet(1:m, 2:n+1) + zet(1:m, 0:n-1)   ) - &
                   re/16.0*((psi(1:m, 2:n+1) - psi(1:m, 0:n-1)) *    &
                            (zet(2:m+1, 1:n) - zet(0:m-1, 1:n)) -    &
                            (psi(2:m+1, 1:n) - psi(0:m-1, 1:n)) *    &
                            (zet(1:m, 2:n+1) - zet(1:m, 0:n-1))  )
!$omp end parallel workshare

end subroutine jacobistepvort

double precision function deltasq(new, old, m, n)

  integer :: m, n, j
  double precision, dimension(0:m+1, 0:n+1) :: new, old

  integer :: ierr

  deltasq = 0.0

!$omp  parallel do default(none) &
!$omp& private(j) shared(new,old,m,n) reduction(+:deltasq)
  do j = 1, n
     deltasq = deltasq + sum((new(1:m,j)-old(1:m,j))**2)
  end do
!$omp end parallel do

end function deltasq

end module jacobi


   FUNCTION Quadrilinear(Vmid,HyperCube,dt,dx,dy,dz) RESULT (F)

     IMPLICIT NONE
     REAL(KIND(0D0)),DIMENSION(0:1,0:1,0:1,0:1) :: HyperCube
     REAL(KIND(0D0)),DIMENSION(0:3) :: Vmid
     REAL(KIND(0D0)) :: dt, dx, dy, dz, F
     REAL(KIND(0D0)) :: t, x, y, z
     INTEGER :: n,i,j,k

     F = 0D0
     t = Vmid(0)/dt
     x = Vmid(1)/dx
     y = Vmid(2)/dy
     z = Vmid(3)/dz

     DO k = 0,1
        DO j = 0,1
           DO i = 0,1
              DO n = 0,1
                 F = F + (n*t+(1-n)*(1-t))*(i*x+(1-i)*(1-x))     &
                        *(j*y+(1-j)*(1-y))*(k*z+(1-k)*(1-z))     &
                        *HyperCube(n,i,j,k)

              END DO
           END DO
        END DO
     END DO

   END FUNCTION Quadrilinear


      module MOD_REGULA
      contains
C**********  MODULNAME: REGULA    ******* 24/03/87  22.00.45.******    46 KARTEN
      SUBROUTINE REGULA(F,X,Y,X1,X2,EPS)
C***********************************************************************
C***  THIS ROUTINE CALCULATES THE SOLUTION X OF F(X)=Y IN THE INTERVAL
C***  (X1,X2) | METHOD:
C***  -------- REGULA FALSI --------
C***  USING BISECTION STEPS TO GUARANTEE CONVERGENCE, PRECISION IN X: EPS
C***********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DATA ANULL/0.d0/
      LOGICAL BI

      BI=.TRUE.
      A=X1
      B=X2
      FA=F(A)-Y
      IF(FA.EQ..0) GOTO 3
      FB=F(B)-Y
      IF(FB.EQ..0) GOTO 4
      IF (FA*FB.GT..0) THEN
            PRINT 10,A,B,FA,FB
 10         FORMAT(//,10X,20(1H*),' ERROR IN REGULA ',20(1H*),/,
     $      10X,'INTERVAL:      A =',E15.5,10X,'   B =',E15.5,/,
     $      10X,'FUNCTION:   F(A) =',E15.5,10X,'F(B) =',E15.5,/,
     $      10X,20(1H*),' ERROR IN REGULA ',20(1H*),/)
            fnull = F(ANULL)
            fa=f(a)
            fb=f(b)
            print *,' Y    = ',Y
            print *,' F(0) = ',fnull
            print *,' F(A) = ',fa
            print *,' F(B) = ',fb

c** creat run time error to find out which was the calling routine
            print *,' run time error deliberate!'
            error=FB/ANULL
            error=error**2.
            print *,error
            STOP 'ERROR'
            ENDIF
    1 D=A-B
      IF(ABS(D).LT.EPS) GOTO 5
      BI=.NOT.BI
      IF(BI) X=A-FA*D/(FA-FB)
      IF(.NOT.BI) X=.5*(A+B)
      FX=F(X)-Y
      IF(FX.EQ..0) RETURN
      IF(FX*FA.GT..0) GOTO 2
      B=X
      FB=FX
      GOTO 1
    2 A=X
      FA=FX
      GOTO 1
    3 X=A
      RETURN
    4 X=B
      RETURN
    5 X=(A+B)*.5
      RETURN
      END subroutine
      end module


	program realftest
c
c
c
	common /winblk/ window(1024)
	dimension data(2050),pwr(513)
	complex cgain,cdata(2050)

	data twopi /6.2831853/
c
	cycles = 10.			! number of cycles in full sample
	period = 1024./cycles			! period in samples
	amp = 1000.
c
c	construct a sine wave
c
	do i = 1,1024
		data(i) = amp*sin(twopi*(i-1)*cycles/1024. + .125*TWOPI)
c		data(i) = amp*sin(twopi*(i-1)*cycles/1024.)
	   write(22,*) i,data(i)
	enddo
c
C	call fwindw(1)
C	do i = 1,1024
C		data(i) = window(i)*data(i)
C	enddo
	call realft(data,512,1)
	do i = 1,512
		data(i) = data(i)/512.
		data(i+512) = data(i+512)/512.
		pwr(i) = sqrt(data(2*i-1)**2 + data(2*i)**2)/512.
	   write(23,*) i,pwr(i)
	enddo
	print*,'data, fourier coefficients'
	print*,(data(j),j=1,25)
	xph = cosd(45.)
	cgain = cmplx(xph,xph)            ! gain with +45 deg. phase shift
	do j = 1,513
	  cdata(j) = cmplx(data(2*j-1),data(2*j))
	  cdata(j) = cdata(j)/cgain
        enddo
	print*,'cdata'
	print*,(cdata(j),j=1,13)
c
c	test inverse transform
c
	call realft(data,512,-1)
	   write(24,*) (i,data(i),i=1,1024)
c
C	DO J = 1,1025
C	  WRITE(67,*) J,DATA(J),WINDOW(J)
C	ENDDO
	stop
	end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!       A function that calculates the values of shape functions
!       at specified points for Quadrilateral Elements
!
!
!_______________________________________________________________________
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Real*8 Function SFQuadrilateral (PsiCor,d,Poly_Order,node,NDim,iS)
    !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    !-----------------------------------------------------------------------
    Implicit real*8 (a-h,o-z)
    Integer Poly_Order,d(NDim),dX(1),dY(1),dZ(1),Deriv
    Dimension Sfn(ndim+1),PsiCor(ndim),PsiCorX(1),PsiCorY(1),PsiCorZ(1)
    !     NDim = dimension of the quadrilateral
    !     NDim= 1 Not considered, resort to Simplex Elements
    !     NDim= 2 Square
    !     NDim= 3 Cube
    !     Poly_Order: complete Polynomial degree of the shape function
    !        iS=0: family of Lagrangian elements (valid for Poly_Order>1)
    !        NDim=2 ->  9-node element
    !        NDim=3 -> 27-node element
    !        iS=1: family of Serendipity elements (valid for Poly_Order>1)
    !        NDim=2 ->  8-node element
    !        NDim=3 -> 20-node element
    !     node: number (ordinal) of the shape function)
    !     PsiCor(ndim)= Simplex intrinsec coordinates
    !     Deriv: order  of Partial DERIVATIVE (Function=:0)
    !     d(1): order of derivation with respect to Psi1
    !     d(2): order of derivation with respect to Psi2
    !     d(3): order of derivation with respect to Psi3
    !     Sfn(i): Linear Shape Function  corresponding to Node i

    SFQuadrilateral = 0.0D0
    Xi = 0.0D0
    Yi = 0.0D0
    Zi = 0.0D0
    Deriv = sum(d)
    Select Case (NDim)
           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        Case (3)
            ! Cube Element
            X  = PsiCor(1)
            Y  = PsiCor(2)
            Z  = PsiCor(3)
            XX = X*X
            YY = Y*Y
            ZZ = Z*Z

            ! Xi: Coordenada X del nodo correspondiente a la funcion de forma Ni
            ! Yi: Coordenada Y del nodo correspondiente a la funcion de forma Ni
            ! Zi: Coordenada Z del nodo correspondiente a la funcion de forma Ni

            !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            Select Case (Poly_Order)
                   ! Linear:1, Quadratic:2, Cubic:3, Etc.
                Case (1)
                    ! Poly_Order Linear
                    Select Case (node)
                        Case(1)
                            Xi = -1.0d0
                            Yi = -1.0d0
                            Zi = -1.0d0
                        Case(2)
                            Xi =  1.0d0
                            Yi = -1.0d0
                            Zi = -1.0d0
                        Case(3)
                            Xi =  1.0d0
                            Yi =  1.0d0
                            Zi = -1.0d0
                        Case(4)
                            Xi = -1.0d0
                            Yi =  1.0d0
                            Zi = -1.0d0
                        Case(5)
                            Xi = -1.0d0
                            Yi = -1.0d0
                            Zi =  1.0d0
                        Case(6)
                            Xi =  1.0d0
                            Yi = -1.0d0
                            Zi =  1.0d0
                        Case(7)
                            Xi =  1.0d0
                            Yi =  1.0d0
                            Zi =  1.0d0
                        Case(8)
                            Xi = -1.0d0
                            Yi =  1.0d0
                            Zi =  1.0d0
                    End Select
                    Select Case (Deriv)
                        Case (0)
                            ! Function Values
                            SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                        Case (1)
                            ! First Order Derivative
                            If(d(1).eq.1)Then                                          ! d/dx
                                SFQuadrilateral = 0.125d0*Xi*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                            ElseIf(d(2).eq.1)Then                                      ! d/dy
                                SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*Yi*(1.0d0+Zi*Z)
                            ElseIf(d(3).eq.1)Then                                      ! d/dz
                                SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*Zi
                            EndIf
                        Case (2)
                            ! Second Order Derivative
                            If(d(1).eq.2)Then                                          ! d2/dx2
                                SFQuadrilateral = 0.0d0
                            ElseIf(d(2).eq.2)Then                                      ! d2/dy2
                                SFQuadrilateral = 0.0d0
                            ElseIf(d(3).eq.2)Then                                      ! d2/dz2
                                SFQuadrilateral = 0.0d0
                            ElseIf(d(1)+d(2).eq.2.and.d(1).ne.2.and.d(2).ne.2)Then     ! d2/dxdy
                                SFQuadrilateral = 0.125d0*Xi*Yi*(1.0d0+Zi*Z)
                            ElseIf(d(1)+d(3).eq.2.and.d(1).ne.2.and.d(3).ne.2)Then     ! d2/dxdz
                                SFQuadrilateral = 0.125d0*Xi*(1.0d0+Yi*Y)*Zi
                            ElseIf(d(2)+d(3).eq.2.and.d(2).ne.2.and.d(3).ne.2)Then     ! d2/dydz
                                SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*Yi*Zi
                            EndIf
                    End Select

                Case (2)
                    ! Poly_Order Cuadratic
                    If(iS.eq.0)Then
                        !----------------------------------------------------------------------
                        ! Lagrangian Element (27-node element)
                        !----------------------------------------------------------------------

                        ! Construido por multiplicacion de las funciones de forma del 1D
                        ! fX: funcion de variable X
                        ! gY: funcion de variable Y
                        ! hZ: funcion de variable Z

                        NDim1D = 1
                        iOrder = 2
                        PsiCorX(1) = X
                        PsiCorY(1) = Y
                        PsiCorZ(1) = Z
                        Select Case (node)
                            Case(1)
                                nodeX = 1
                                nodeY = 1
                                nodeZ = 1
                            Case(2)
                                nodeX = 2
                                nodeY = 1
                                nodeZ = 1
                            Case(3)
                                nodeX = 2
                                nodeY = 2
                                nodeZ = 1
                            Case(4)
                                nodeX = 1
                                nodeY = 2
                                nodeZ = 1
                            Case(5)
                                nodeX = 1
                                nodeY = 1
                                nodeZ = 2
                            Case(6)
                                nodeX = 2
                                nodeY = 1
                                nodeZ = 2
                            Case(7)
                                nodeX = 2
                                nodeY = 2
                                nodeZ = 2
                            Case(8)
                                nodeX = 1
                                nodeY = 2
                                nodeZ = 2
                            Case(9)
                                nodeX = 3
                                nodeY = 1
                                nodeZ = 1
                            Case(10)
                                nodeX = 2
                                nodeY = 3
                                nodeZ = 1
                            Case(11)
                                nodeX = 3
                                nodeY = 2
                                nodeZ = 1
                            Case(12)
                                nodeX = 1
                                nodeY = 3
                                nodeZ = 1
                            Case(13)
                                nodeX = 1
                                nodeY = 1
                                nodeZ = 3
                            Case(14)
                                nodeX = 2
                                nodeY = 1
                                nodeZ = 3
                            Case(15)
                                nodeX = 2
                                nodeY = 2
                                nodeZ = 3
                            Case(16)
                                nodeX = 1
                                nodeY = 2
                                nodeZ = 3
                            Case(17)
                                nodeX = 3
                                nodeY = 1
                                nodeZ = 2
                            Case(18)
                                nodeX = 2
                                nodeY = 3
                                nodeZ = 2
                            Case(19)
                                nodeX = 3
                                nodeY = 2
                                nodeZ = 2
                            Case(20)
                                nodeX = 1
                                nodeY = 3
                                nodeZ = 2
                            Case(21)
                                nodeX = 3
                                nodeY = 3
                                nodeZ = 1
                            Case(22)
                                nodeX = 3
                                nodeY = 1
                                nodeZ = 3
                            Case(23)
                                nodeX = 2
                                nodeY = 3
                                nodeZ = 3
                            Case(24)
                                nodeX = 3
                                nodeY = 2
                                nodeZ = 3
                            Case(25)
                                nodeX = 1
                                nodeY = 3
                                nodeZ = 3
                            Case(26)
                                nodeX = 3
                                nodeY = 3
                                nodeZ = 2
                            Case(27)
                                nodeX = 3
                                nodeY = 3
                                nodeZ = 3
                        End Select
                        Select Case (Deriv)
                            Case(0)
                                ! Function Values
                                dX(1) = 0
                                dY(1) = 0
                                dZ(1) = 0
                            Case(1)
                                ! First Order Derivative
                                If(d(1).eq.1)Then                ! d/dx
                                    dX(1) = 1
                                    dY(1) = 0
                                    dZ(1) = 0
                                ElseIf(d(2).eq.1)Then            ! d/dy
                                    dX(1) = 0
                                    dY(1) = 1
                                    dZ(1) = 0
                                Else                             ! d/dz
                                    dX(1) = 0
                                    dY(1) = 0
                                    dZ(1) = 1
                                EndIf
                            Case(2)
                                ! Second Order Derivative
                                If(d(1).eq.2)Then                ! d2/dx2
                                    dX(1) = 2
                                    dY(1) = 0
                                    dZ(1) = 0
                                ElseIf(d(2).eq.2)Then            ! d2/dy2
                                    dX(1) = 0
                                    dY(1) = 2
                                    dZ(1) = 0
                                ElseIf(d(3).eq.2)Then            ! d2/dz2
                                    dX(1) = 0
                                    dY(1) = 0
                                    dZ(1) = 2
                                ElseIf(d(1)+d(2).eq.2)Then       ! d2/dxdy
                                    dX(1) = 1
                                    dY(1) = 1
                                    dZ(1) = 0
                                ElseIf(d(1)+d(3).eq.2)Then       ! d2/dxdz
                                    dX(1) = 1
                                    dY(1) = 0
                                    dZ(1) = 1
                                Else                             ! d2/dydz
                                    dX(1) = 0
                                    dY(1) = 1
                                    dZ(1) = 1
                                EndIf
                        End Select
                        fX = SF1D(PsiCorX,dX,iOrder,nodeX,NDim1D,0)
                        gY = SF1D(PsiCorY,dY,iOrder,nodeY,NDim1D,0)
                        hZ = SF1D(PsiCorZ,dZ,iOrder,nodeZ,NDim1D,0)
                        SFQuadrilateral = fX * gY * hZ
                       !----------------------------------------------------------------------
                    ElseIf(iS.eq.1)Then
                        !----------------------------------------------------------------------
                        ! Serendipity Element (20-node element)
                        !----------------------------------------------------------------------
                        Select Case (node)
                            Case(1)
                                Xi = -1.0d0
                                Yi = -1.0d0
                                Zi = -1.0d0
                            Case(2)
                                Xi =  1.0d0
                                Yi = -1.0d0
                                Zi = -1.0d0
                            Case(3)
                                Xi =  1.0d0
                                Yi =  1.0d0
                                Zi = -1.0d0
                            Case(4)
                                Xi = -1.0d0
                                Yi =  1.0d0
                                Zi = -1.0d0
                            Case(5)
                                Xi = -1.0d0
                                Yi = -1.0d0
                                Zi =  1.0d0
                            Case(6)
                                Xi =  1.0d0
                                Yi = -1.0d0
                                Zi =  1.0d0
                            Case(7)
                                Xi =  1.0d0
                                Yi =  1.0d0
                                Zi =  1.0d0
                            Case(8)
                                Xi = -1.0d0
                                Yi =  1.0d0
                                Zi =  1.0d0
                            Case(9)
                                Xi =  0.0d0
                                Yi = -1.0d0
                                Zi = -1.0d0
                            Case(10)
                                Xi =  1.0d0
                                Yi =  0.0d0
                                Zi = -1.0d0
                            Case(11)
                                Xi =  0.0d0
                                Yi =  1.0d0
                                Zi = -1.0d0
                            Case(12)
                                Xi = -1.0d0
                                Yi =  0.0d0
                                Zi = -1.0d0
                            Case(13)
                                Xi = -1.0d0
                                Yi = -1.0d0
                                Zi =  0.0d0
                            Case(14)
                                Xi =  1.0d0
                                Yi = -1.0d0
                                Zi =  0.0d0
                            Case(15)
                                Xi =  1.0d0
                                Yi =  1.0d0
                                Zi =  0.0d0
                            Case(16)
                                Xi = -1.0d0
                                Yi =  1.0d0
                                Zi =  0.0d0
                            Case(17)
                                Xi =  0.0d0
                                Yi = -1.0d0
                                Zi =  1.0d0
                            Case(18)
                                Xi =  1.0d0
                                Yi =  0.0d0
                                Zi =  1.0d0
                            Case(19)
                                Xi =  0.0d0
                                Yi =  1.0d0
                                Zi =  1.0d0
                            Case(20)
                                Xi = -1.0d0
                                Yi =  0.0d0
                                Zi =  1.0d0
                        End Select
                        Select Case (Deriv)
                            Case (0)
                                ! Function Values
                                Select Case (node)
                                    Case (1:8)
                                        SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)*(Xi*X+Yi*Y+Zi*Z-2)
                                    Case (9,11,17,19)
                                        SFQuadrilateral = 0.25d0*(1.0d0-XX)*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                                    Case (10,12,18,20)
                                        SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0-YY)*(1.0d0+Zi*Z)
                                    Case (13:16)
                                        SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*(1.0d0-ZZ)
                                End Select
                            Case (1)
                                ! First Order Derivative
                                Select Case (node)
                                    Case (1:8)
                                        If(d(1).eq.1)Then                                 ! d/dx
                                            SFQuadrilateral = 0.125d0*Xi*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)*(2.0d0*Xi*X+Yi*Y+Zi*Z-1.0D0)
                                        ElseIf(d(2).eq.1)Then                             ! d/dy
                                            SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*Yi*(1.0d0+Zi*Z)*(Xi*X+2.0d0*Yi*Y+Zi*Z-1.0D0)
                                        Else                                              ! d/dz
                                            SFQuadrilateral = 0.125d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*Zi*(Xi*X+Yi*Y+2.0d0*Zi*Z-1.0D0)
                                        EndIf
                                    Case (9,11,17,19)
                                        If(d(1).eq.1)Then                                 ! d/dx
                                            SFQuadrilateral = -0.50d0*X*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                                        ElseIf(d(2).eq.1)Then                             ! d/dy
                                            SFQuadrilateral = 0.25d0*(1.0d0-XX)*Yi*(1.0d0+Zi*Z)
                                        Else                                              ! d/dz
                                            SFQuadrilateral = 0.25d0*(1.0d0-XX)*(1.0d0+Yi*Y)*Zi
                                        EndIf
                                    Case (10,12,18,20)
                                        If(d(1).eq.1)Then                                 ! d/dx
                                            SFQuadrilateral = 0.25d0*Xi*(1.0d0-YY)*(1.0d0+Zi*Z)
                                        ElseIf(d(2).eq.1)Then                             ! d/dy
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*Y*(1.0d0+Zi*Z)
                                        Else                                              ! d/dz
                                            SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0-YY)*Zi
                                        EndIf
                                    Case (13:16)
                                        If(d(1).eq.1)Then                                 ! d/dx
                                            SFQuadrilateral = 0.25d0*Xi*(1.0d0+Yi*Y)*(1.0d0-ZZ)
                                        ElseIf(d(2).eq.1)Then                             ! d/dy
                                            SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*Yi*(1.0d0-ZZ)
                                        Else                                              ! d/dz
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*Z
                                        EndIf
                                End Select
                            Case (2)
                                ! Second Order Derivative
                                Select Case (node)
                                    Case (1:8)
                                        If(d(1).eq.2)Then                                 ! d2/dx2
                                            SFQuadrilateral = 0.25d0*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                                        ElseIf(d(2).eq.2)Then                             ! d2/dy2
                                            SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0+Zi*Z)
                                        ElseIf(d(3).eq.2)Then                             ! d2/dz2
                                            SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)
                                        ElseIf(d(1)+d(2).eq.2)Then                        ! d2/dxdy
                                            SFQuadrilateral = 0.125d0*Xi*Yi*(1.0d0+Zi*Z)*(2.0d0*Xi*X+2.0d0*Yi*Y+Zi*Z)
                                        ElseIf(d(1)+d(3).eq.2)Then                        ! d2/dxdz
                                            SFQuadrilateral = 0.125d0*Xi*Zi*(1.0d0+Yi*Y)*(2.0d0*Xi*X+Yi*Y+2.0d0*Zi*Z)
                                        Else                                              ! d2/dydz
                                            SFQuadrilateral = 0.125d0*Yi*Zi*(1.0d0+Xi*X)*(Xi*X+2.0d0*Yi*Y+2.0d0*Zi*Z)
                                        EndIf
                                    Case (9,11,17,19)
                                        If(d(1).eq.2)Then                                 ! d2/dx2
                                            SFQuadrilateral = -0.50d0*(1.0d0+Yi*Y)*(1.0d0+Zi*Z)
                                        ElseIf(d(2).eq.2)Then                             ! d2/dy2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(3).eq.2)Then                             ! d2/dz2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(1)+d(2).eq.2)Then                        ! d2/dxdy
                                            SFQuadrilateral = -0.50d0*X*Yi*(1.0d0+Zi*Z)
                                        ElseIf(d(1)+d(3).eq.2)Then                        ! d2/dxdz
                                            SFQuadrilateral = -0.50d0*X*(1.0d0+Yi*Y)*Zi
                                        Else                                              ! d2/dydz
                                            SFQuadrilateral = 0.25d0*(1.0d0-XX)*Yi*Zi
                                        EndIf
                                    Case (10,12,18,20)
                                        If(d(1).eq.2)Then                                 ! d2/dx2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(2).eq.2)Then                             ! d2/dy2
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*(1.0d0+Zi*Z)
                                        ElseIf(d(3).eq.2)Then                             ! d2/dz2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(1)+d(2).eq.2)Then                        ! d2/dxdy
                                            SFQuadrilateral = -0.50d0*Xi*Y*(1.0d0+Zi*Z)
                                        ElseIf(d(1)+d(3).eq.2)Then                        ! d2/dxdz
                                            SFQuadrilateral = 0.25d0*Xi*(1.0d0-YY)*Zi
                                        Else                                              ! d2/dydz
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*Y*Zi
                                        EndIf
                                    Case (13:16)
                                        If(d(1).eq.2)Then                                 ! d2/dx2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(2).eq.2)Then                             ! d2/dy2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(3).eq.2)Then                             ! d2/dz2
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)
                                        ElseIf(d(1)+d(2).eq.2)Then                        ! d2/dxdy
                                            SFQuadrilateral = 0.25d0*Xi*Yi*(1.0d0-ZZ)
                                        ElseIf(d(1)+d(3).eq.2)Then                        ! d2/dxdz
                                            SFQuadrilateral = -0.50d0*Xi*(1.0d0+Yi*Y)*Z
                                        Else                                              ! d2/dydz
                                            SFQuadrilateral = -0.50d0*(1.0d0+Xi*X)*Yi*Z
                                        EndIf
                                End Select
                        End Select
                    EndIf

            End Select

           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        Case (2)
            ! Square Element
            X  = PsiCor(1)
            Y  = PsiCor(2)
            XX = X*X
            YY = Y*Y

            ! Xi: Coordenada X del nodo correspondiente a la funcion de forma Ni
            ! Yi: Coordenada Y del nodo correspondiente a la funcion de forma Ni

            !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            Select Case (Poly_Order)
                   ! Linear:1, Quadratic:2, Cubic:3, Etc.
                Case (1)
                    ! Poly_Order Linear
                    Select Case (node)
                        Case(1)
                            Xi = -1.0d0
                            Yi = -1.0d0
                        Case(2)
                            Xi =  1.0d0
                            Yi = -1.0d0
                        Case(3)
                            Xi =  1.0d0
                            Yi =  1.0d0
                        Case(4)
                            Xi = -1.0d0
                            Yi =  1.0d0
                    End Select
                    Select Case (Deriv)
                        Case (0)
                            ! Function Values
                            SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)
                        Case (1)
                            ! First Order Derivative
                            If(d(1).eq.1)Then                                     ! d/dx
                                SFQuadrilateral = 0.25d0*Xi*(1.0d0+Yi*Y)
                            Else                                                  ! d/dy
                                SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*Yi
                            EndIf
                        Case (2)
                            ! Second Order Derivative
                            If(d(1).eq.2)Then                                     ! d2/dx2
                                SFQuadrilateral = 0.0d0
                            ElseIf(d(2).eq.2)Then                                 ! d2/dy2
                                SFQuadrilateral = 0.0d0
                            Else                                                  ! d2/dxdy
                                SFQuadrilateral = 0.25d0*Xi*Yi
                            EndIf
                    End Select

                Case (2)
                    ! Poly_Order Cuadratic
                    If(iS.eq.0)Then
                        !----------------------------------------------------------------------
                        ! Lagrangian Element
                        !----------------------------------------------------------------------

                        ! Construido por multiplicacion de las funciones de forma del 1D
                        ! fX: funcion de variable X
                        ! gY: funcion de variable Y

                        NDim1D = 1
                        iOrder = 2
                        PsiCorX(1) = X
                        PsiCorY(1) = Y
                        Select Case (node)
                            Case(1)
                                nodeX = 1
                                nodeY = 1
                            Case(2)
                                nodeX = 2
                                nodeY = 1
                            Case(3)
                                nodeX = 2
                                nodeY = 2
                            Case(4)
                                nodeX = 1
                                nodeY = 2
                            Case(5)
                                nodeX = 3
                                nodeY = 1
                            Case(6)
                                nodeX = 2
                                nodeY = 3
                            Case(7)
                                nodeX = 3
                                nodeY = 2
                            Case(8)
                                nodeX = 1
                                nodeY = 3
                            Case(9)
                                nodeX = 3
                                nodeY = 3
                        End Select
                        Select Case (Deriv)
                            Case(0)
                                ! Function Values
                                dX(1) = 0
                                dY(1) = 0
                            Case(1)
                                ! First Order Derivative
                                If(d(1).eq.1)Then                           ! d/dx
                                    dX(1) = 1
                                    dY(1) = 0
                                Else                                        ! d/dy
                                    dX(1) = 0
                                    dY(1) = 1
                                EndIf
                            Case(2)
                                ! Second Order Derivative
                                If(d(1).eq.2)Then                           ! d2/dx2
                                    dX(1) = 2
                                    dY(1) = 0
                                ElseIf(d(2).eq.2)Then                       ! d2/dy2
                                    dX(1) = 0
                                    dY(1) = 2
                                Else                                        ! d2/dxdy
                                    dX(1) = 1
                                    dY(1) = 1
                                EndIf
                        End Select
                        fX = SF1D(PsiCorX,dX,iOrder,nodeX,NDim1D,0)
                        gY = SF1D(PsiCorY,dY,iOrder,nodeY,NDim1D,0)
                        SFQuadrilateral = fX * gY
                       !----------------------------------------------------------------------
                    ElseIf(iS.eq.1.or.iS.eq.2)Then
                        !----------------------------------------------------------------------
                        ! Serendipity or less than Serendipity Element (coincide for NDim=2)
                        !----------------------------------------------------------------------
                        Select Case (node)
                            Case(1)
                                Xi = -1.0d0
                                Yi = -1.0d0
                            Case(2)
                                Xi =  1.0d0
                                Yi = -1.0d0
                            Case(3)
                                Xi =  1.0d0
                                Yi =  1.0d0
                            Case(4)
                                Xi = -1.0d0
                                Yi =  1.0d0
                            Case(5)
                                Xi =  0.0d0
                                Yi = -1.0d0
                            Case(6)
                                Xi =  1.0d0
                                Yi =  0.0d0
                            Case(7)
                                Xi =  0.0d0
                                Yi =  1.0d0
                            Case(8)
                                Xi = -1.0d0
                                Yi =  0.0d0
                        End Select
                        Select Case (Deriv)
                            Case (0)
                                ! Function Values
                                Select Case (node)
                                    Case (1:4)
                                        SFQuadrilateral = 0.25d0*(1.0d0+Xi*X)*(1.0d0+Yi*Y)*(Xi*X+Yi*Y-1)
                                    Case (5,7)
                                        SFQuadrilateral = 0.50d0*(1.0d0-XX)*(1.0d0+Yi*Y)
                                    Case (6,8)
                                        SFQuadrilateral = 0.50d0*(1.0d0+Xi*X)*(1.0d0-YY)
                                End Select
                            Case (1)
                                ! First Order Derivative
                                Select Case (node)
                                    Case (1:4)
                                        If(d(1).eq.1)Then                             ! d/dx
                                            SFQuadrilateral = 0.25d0*Xi*(1.0d0+Yi*Y)*(2.0d0*Xi*X+Yi*Y)
                                        Else                                          ! d/dy
                                            SFQuadrilateral = 0.25d0*Yi*(1.0d0+Xi*X)*(2.0d0*Yi*Y+Xi*X)
                                        EndIf
                                    Case (5,7)
                                        If(d(1).eq.1)Then                             ! d/dx
                                            SFQuadrilateral = -X*(1.0d0+Yi*Y)
                                        Else                                          ! d/dy
                                            SFQuadrilateral = 0.50d0*(1-XX)*Yi
                                        EndIf
                                    Case (6,8)
                                        If(d(1).eq.1)Then                             ! d/dx
                                            SFQuadrilateral = 0.50d0*Xi*(1-YY)
                                        Else                                          ! d/dy
                                            SFQuadrilateral = -(1.0d0+Xi*X)*Y
                                        EndIf
                                End Select
                            Case (2)
                                ! Second Order Derivative
                                Select Case (node)
                                    Case (1,4)
                                        If(d(1).eq.2)Then                              ! d2/dx2
                                            SFQuadrilateral = 0.50d0*(1.0D0+Yi*Y)
                                        ElseIf(d(2).eq.2)Then                          ! d2/dy2
                                            SFQuadrilateral = 0.50d0*(1.0D0+Xi*X)
                                        Else                                           ! d2/dxdy
                                            SFQuadrilateral = 0.25d0*(1.0d0+2.0d0*Xi*X+2.0d0*Yi*Y)
                                        EndIf
                                    Case (5,7)
                                        If(d(1).eq.2)Then                              ! d2/dx2
                                            SFQuadrilateral = -(1.0d0+Yi*Y)
                                        ElseIf(d(2).eq.2)Then                          ! d2/dy2
                                            SFQuadrilateral = 0.0d0
                                        Else                                           ! d2/dxdy
                                            SFQuadrilateral = -X*Yi
                                        EndIf
                                    Case (6,8)
                                        If(d(1).eq.2)Then                              ! d2/dx2
                                            SFQuadrilateral = 0.0d0
                                        ElseIf(d(2).eq.2)Then                          ! d2/dy2
                                            SFQuadrilateral = -(1.0d0+Xi*X)
                                        Else                                           ! d2/dxdy
                                            SFQuadrilateral = -Xi*Y
                                        EndIf
                                End Select
                        End Select
                       !----------------------------------------------------------------------
                    EndIf

            End Select

           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
           !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        Case (1)
            ! Line Element
            X  = PsiCor(1)
            XX = X*X

            ! Xi: Coordenada X del nodo correspondiente a la funcion de forma Ni

            !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
            Select Case (Poly_Order)
                   ! Linear:1, Quadratic:2, Cubic:3, Etc.
                Case (1)
                    ! Poly_Order Linear
                    Select Case (Deriv)
                        Case (0)
                            ! Function Values
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = 0.50d0*(1.0d0-X)
                                Case(2)
                                    SFQuadrilateral = 0.50d0*(1.0d0+X)
                            End Select
                        Case (1)
                            ! First Order Derivative
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = -0.50d0
                                Case(2)
                                    SFQuadrilateral = 0.50d0
                            End Select
                        Case (2)
                            ! Second Order Derivative
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = 0.0d0
                                Case(2)
                                    SFQuadrilateral = 0.0d0
                            End Select
                    End Select

                Case (2)
                    ! Poly_Order Cuadratic
                    Select Case (Deriv)
                        Case (0)
                            ! Function Values
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = -0.50d0*X*(1.0d0-X)
                                Case(2)
                                    SFQuadrilateral = 0.50d0*X*(1.0d0+X)
                                Case(3)
                                    SFQuadrilateral = 1.0d0-XX
                            End Select
                        Case (1)
                            ! First Order Derivative
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = -0.50d0*(1.0d0-2.0d0*X)
                                Case(2)
                                    SFQuadrilateral = 0.50d0*(1.0d0+2.0d0*X)
                                Case(3)
                                    SFQuadrilateral = -2.0d0*X
                            End Select
                        Case (2)
                            ! Second Order Derivative
                            Select Case (node)
                                Case(1)
                                    SFQuadrilateral = 1.0d0
                                Case(2)
                                    SFQuadrilateral = 1.0d0
                                Case(3)
                                    SFQuadrilateral = -2.0d0
                            End Select
                    End Select

            End Select
    End Select

    Return
End Function SFQuadrilateral
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!       A function that calculates the values of shape functions
!       at specified points for line Elements in (-1,1) for building
!                quadrilateral Lagrangian elements
!
!_______________________________________________________________________
!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Real*8 Function SF1D (PsiCor,d,Poly_Order,node,NDim,iS)
    !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    !-----------------------------------------------------------------------
    Implicit real*8 (a-h,o-z)
    Integer Poly_Order,d(NDim),dX(1),dY(1),dZ(1),Deriv
    Dimension Sfn(ndim+1),PsiCor(ndim),PsiCorX(1),PsiCorY(1),PsiCorZ(1)
    !     NDim= 1
    !     Poly_Order: complete Polynomial degree of the shape function
    !     iS=0: family of Lagrangian elements (valid for Poly_Order>1)
    !     node: number (ordinal) of the shape function)
    !     PsiCor(ndim)= Simplex intrinsec coordinates
    !     Deriv: order  of Partial DERIVATIVE (Function=:0)

    Deriv = sum(d)
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    ! Line Element

    X  = PsiCor(1)
    XX = X*X
    SF1D = 0.0D0

    ! Xi: Coordenada X del nodo correspondiente a la funcion de forma Ni

    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Select Case (Poly_Order)
           ! Linear:1, Quadratic:2, Cubic:3, Etc.
        Case (1)
            ! Poly_Order Linear
            Select Case (Deriv)
                Case (0)
                    ! Function Values
                    Select Case (node)
                        Case(1)
                            SF1D = 0.50d0*(1.0d0-X)
                        Case(2)
                            SF1D = 0.50d0*(1.0d0+X)
                    End Select
                Case (1)
                    ! First Order Derivative
                    Select Case (node)
                        Case(1)
                            SF1D = -0.50d0
                        Case(2)
                            SF1D = 0.50d0
                    End Select
                Case (2)
                    ! Second Order Derivative
                    Select Case (node)
                        Case(1)
                            SF1D = 0.0d0
                        Case(2)
                            SF1D = 0.0d0
                    End Select
            End Select

        Case (2)
            ! Poly_Order Cuadratic
            Select Case (Deriv)
                Case (0)
                    ! Function Values
                    Select Case (node)
                        Case(1)
                            SF1D = -0.50d0*X*(1.0d0-X)
                        Case(2)
                            SF1D = 0.50d0*X*(1.0d0+X)
                        Case(3)
                            SF1D = 1.0d0-XX
                    End Select
                Case (1)
                    ! First Order Derivative
                    Select Case (node)
                        Case(1)
                            SF1D = -0.50d0*(1.0d0-2.0d0*X)
                        Case(2)
                            SF1D = 0.50d0*(1.0d0+2.0d0*X)
                        Case(3)
                            SF1D = -2.0d0*X
                    End Select
                Case (2)
                    ! Second Order Derivative
                    Select Case (node)
                        Case(1)
                            SF1D = 1.0d0
                        Case(2)
                            SF1D = 1.0d0
                        Case(3)
                            SF1D = -2.0d0
                    End Select
            End Select

    End Select

    Return
End Function SF1D
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

! keywords
! Derivadas de funciones de forma lineares para Brics / Quads / Cubos
! Shape derivative functions linear
! Joaquin Aranciaga
! Santiago
! Souza Neto
! Fbar
! 2015
! Residual Stress
! ndim=2 y ndim=3

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SubRoutine localShapeFunctionHyperCube (Ndim, lsf, Gauss)

    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit Real*8 (a-h, o-z)

    Real*8 lsf

          ! http://www.colorado.edu/engineering/CAS/courses.d/AFEM.d/AFEM.Ch11.d/AFEM.Ch11.pdf

    Dimension lsf(8), Gauss(Ndim)

    if (Ndim == 3) then
        psi_1 = Gauss(1)
        psi_2 = Gauss(2)
        psi_3 = Gauss(3)

        !     Funciones de forma del paralelepopedo lineales en los puntos
        !     de Gauss.

              !lsf(1) = (1.0d0 - psi_2) * (1.0d0 - psi_3) * psi_1 !lsf(1) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * (1.0d0 - psi_3)
        !lsf(2) = (1.0d0 - psi_3) * psi_1 * psi_2 !lsf(2) = (1.0d0 - psi_2) * (1.0d0 - psi_3) * psi_1
        !lsf(3) = (1.0d0 - psi_1) * (1.0d0 - psi_3) * psi_2 !lsf(3) = (1 - psi_3) * psi_1 * psi_2
        !lsf(4) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * (1.0d0 - psi_3) !lsf(4) = (1 - psi_1) * (1 - psi_3) * psi_2
        !lsf(5) = (1.0d0 - psi_2) * psi_1 * psi_3 !lsf(5) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * psi_3
        !lsf(6) = psi_1 * psi_2 * psi_3 !lsf(6) = (1.0d0 - psi_2) * psi_1 * psi_3
        !lsf(7) = (1.0d0 - psi_1) * psi_2 * psi_3 !lsf(7) = psi_1 * psi_2 * psi_3
        !lsf(8) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * psi_3 !lsf(8) = (1.0d0 - psi_1) * psi_2 * psi_3

        lsf(1) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * (1.0d0 - psi_3)
        lsf(2) = (1.0d0 - psi_2) * (1.0d0 - psi_3) * (psi_1 + 1.0d0)
        lsf(3) = (1.0d0 - psi_3) * (psi_1 + 1.0d0) * (psi_2 + 1.0d0)
        lsf(4) = (1.0d0 - psi_1) * (1.0d0 - psi_3) * (psi_2 + 1.0d0)
        lsf(5) = (1.0d0 - psi_1) * (1.0d0 - psi_2) * (psi_3 + 1.0d0)
        lsf(6) = (1.0d0 - psi_2) * (psi_1 + 1.0d0) * (psi_3 + 1.0d0)
        lsf(7) = (psi_1 + 1.0d0) * (psi_2 + 1.0d0) * (psi_3 + 1.0d0)
        lsf(8) = (1.0d0 - psi_1) * (psi_2 + 1.0d0) * (psi_3 + 1.0d0)
        lsf = lsf /8.0d0
    end if

    if (Ndim == 2) then
        psi_1 = Gauss(1)
        psi_2 = Gauss(2)

        lsf(1) = (1.0d0 - psi_1) * (1.0d0 - psi_2)
        lsf(2) = (1.0d0 - psi_2) * (psi_1 + 1.0d0)
        lsf(3) = (psi_1 + 1.0d0) * (psi_2 + 1.0d0)
        lsf(4) = (1.0d0 - psi_1) * (psi_2 + 1.0d0)
        lsf = lsf /4.0d0
    end if

    Return

End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SubRoutine localShapeFunctionDerivativesHyperCube &
    (NodG, Ndim, dlsf, Gauss)

    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Implicit Real*8 (a-h, o-z)

    Dimension dlsf(Ndim, NodG), Gauss(Ndim)

    if (Ndim == 3) then
        psi_1 = Gauss(1)
        psi_2 = Gauss(2)
        psi_3 = Gauss(3)

        dlsf(1,1) = - (1.0d0 - psi_2) * (1.0d0 - psi_3)
        dlsf(1,2) =   (1.0d0 - psi_2) * (1.0d0 - psi_3)
        dlsf(1,3) =   (1.0d0 - psi_3) * (psi_2 + 1.0d0)
        dlsf(1,4) = - (1.0d0 - psi_3) * (psi_2 + 1.0d0)
        dlsf(1,5) = - (1.0d0 - psi_2) * (psi_3 + 1.0d0)
        dlsf(1,6) =   (1.0d0 - psi_2) * (psi_3 + 1.0d0)
        dlsf(1,7) =   (psi_2 + 1.0d0) * (psi_3 + 1.0d0)
        dlsf(1,8) = - (psi_2 + 1.0d0) * (psi_3 + 1.0d0)

        dlsf(2,1) = - (1.0d0 - psi_1) * (1.0d0 - psi_3)
        dlsf(2,2) = - (1.0d0 - psi_3) * (psi_1 + 1.0d0)
        dlsf(2,3) =   (1.0d0 - psi_3) * (psi_1 + 1.0d0)
        dlsf(2,4) =   (1.0d0 - psi_1) * (1.0d0 - psi_3)
        dlsf(2,5) = - (1.0d0 - psi_1) * (psi_3 + 1.0d0)
        dlsf(2,6) = - (psi_1 + 1.0d0) * (psi_3 + 1.0d0)
        dlsf(2,7) =   (psi_1 + 1.0d0) * (psi_3 + 1.0d0)
        dlsf(2,8) =   (1.0d0 - psi_1) * (psi_3 + 1.0d0)

        dlsf(3,1) = - (1.0d0 - psi_1) * (1.0d0 - psi_2)
        dlsf(3,2) = - (1.0d0 - psi_2) * (psi_1 + 1.0d0)
        dlsf(3,3) = - (psi_1 + 1.0d0) * (psi_2 + 1.0d0)
        dlsf(3,4) = - (1.0d0 - psi_1) * (psi_2 + 1.0d0)
        dlsf(3,5) =   (1.0d0 - psi_1) * (1.0d0 - psi_2)
        dlsf(3,6) =   (1.0d0 - psi_2) * (psi_1 + 1.0d0)
        dlsf(3,7) =   (psi_1 + 1.0d0) * (psi_2 + 1.0d0)
        dlsf(3,8) =   (1.0d0 - psi_1) * (psi_2 + 1.0d0)

        dlsf = dlsf / 8.0d0

    end if

    if (Ndim == 2) then
        psi_1 = Gauss(1)
        psi_2 = Gauss(2)

        dlsf(1,1) = - (1.0d0 - psi_2)
        dlsf(1,2) =   (1.0d0 - psi_2)
        dlsf(1,3) =   (psi_2 + 1.0d0)
        dlsf(1,4) = - (psi_2 + 1.0d0)
        dlsf(2,1) = - (1.0d0 - psi_1)
        dlsf(2,2) = - (psi_1 + 1.0d0)
        dlsf(2,3) =   (psi_1 + 1.0d0)
        dlsf(2,4) =   (1.0d0 - psi_1)

        dlsf = dlsf/4.0d0

    end if
    Return

End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


program mean
    use, intrinsic :: iso_fortran_env, only : error_unit, I8 => INT64
    implicit none
    integer, parameter :: nr_runs = 5
    integer(kind=I8) :: nr_values
    integer :: run
    real, dimension(:), allocatable :: values

    call get_arguments(nr_values)

    do run = 1, nr_runs
        values = init_values(nr_values)
        print '(F10.3)', sum(values)/size(values)
    end do

contains

    function init_values(nr_values) result(values)
        implicit none
        integer(kind=I8), value :: nr_values
        real, dimension(:), allocatable :: values
        integer :: status

        allocate(values(nr_values), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A, I0, A)') &
                'error: can not allocate ', nr_values, ' values'
            stop 2
        end if
        call random_number(values)
    end function init_values

    subroutine get_arguments(nr_values)
        implicit none
        integer(kind=I8), intent(out) :: nr_values
        integer :: status
        character(len=1024) :: buffer, msg

        if (command_argument_count() == 1) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) nr_values
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
                stop 1
            end if
        else
            nr_values = 10
        end if
    end subroutine get_arguments

end program mean